darcs-2.4: 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 System.IO ( hSetBinaryMode)
import System.IO ( stdin, stdout )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs )
import Control.Exception ( Exception( AssertionFailed ), handleJust, catchDyn )

import Darcs.RunCommand ( run_the_command )
import Darcs.Flags ( DarcsFlag(Verbose) )
import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion )
import Darcs.SignalHandler ( withSignalsHandled )
import Version ( version, context )
import Darcs.Global ( with_atexit )
import Preproc( preproc_main )
import Exec ( ExecException(..) )
#include "impossible.h"

assertions :: Control.Exception.Exception -> Maybe String
assertions (AssertionFailed s) = Just s
assertions _ = Nothing

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 = with_atexit $ withSignalsHandled $
  flip catchDyn execExceptionHandler $
  handleJust assertions bug $ 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
    ("--preprocess-manual":rest) -> preproc_main rest
    -- User called a normal darcs command, "darcs foo [args]".
    _ -> do
      hSetBinaryMode stdin True
      hSetBinaryMode stdout True
      run_the_command (head argv) (tail argv)