darcs-2.5: src/darcs.hs

-- Copyright (C) 2002-2003 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

module Main (main) where

import Prelude hiding ( catch )

import System.IO ( stdin, stdout, stderr, hSetBinaryMode )
import Control.Monad ( forM_ )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs )
import Control.Exception.Extensible ( AssertionFailed(..), handle, catch )

import Darcs.RunCommand ( runTheCommand )
import Darcs.Flags ( DarcsFlag(Verbose) )
import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion, commandControlList )
import Darcs.SignalHandler ( withSignalsHandled )
import Version ( version, context, builddeps )
import Darcs.Global ( withAtexit )
import Preproc( preprocMain )
import Exec ( ExecException(..) )
#include "impossible.h"

execExceptionHandler :: ExecException -> IO a
execExceptionHandler (ExecException cmd args redirects reason) =
    do putStrLn $ "Failed to execute external command: " ++ unwords (cmd:args) ++ "\n"
                    ++ "Lowlevel error: " ++ reason ++ "\n"
                    ++ "Redirects: " ++ show redirects ++"\n"
       exitWith $ ExitFailure 3

main :: IO ()
main = withAtexit $ withSignalsHandled $
  flip catch execExceptionHandler $
  handle (\(AssertionFailed e) -> bug e) $ do
  argv <- getArgs
  case argv of
    -- User called "darcs" without arguments.
    []                  -> printVersion >> helpCmd [] []
    -- User called "darcs --foo" for some special foo.
    ["-h"]              -> helpCmd [] []
    ["--help"]          -> helpCmd [] []
    ["--overview"]      -> helpCmd [Verbose] []
    ["--commands"]      -> listAvailableCommands
    ["-v"]              -> putStrLn version
    ["--version"]       -> putStrLn version
    ["--exact-version"] -> do
              putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__
              putStrLn context
              putStrLn $ "Compiled with:\n"
              putStr builddeps
    ("--preprocess-manual":rest) -> preprocMain rest
    -- User called a normal darcs command, "darcs foo [args]".
    _ -> do
      forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True
      runTheCommand commandControlList (head argv) (tail argv)