src/Darcs/RunCommand.lhs

   1 %  Copyright (C) 2002,2003,2005 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \begin{code}
  19 module Darcs.RunCommand ( run_the_command ) where
  20
  21 import Control.Exception ( throwIO, Exception ( ExitException ) )
  22 import Control.Monad ( unless, when )
  23 import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),
  24                               OptDescr( Option ),
  25                               getOpt )
  26 import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
  27
  28 import Darcs.Arguments ( DarcsFlag(..),
  29                          help,
  30                          option_from_darcsoption,
  31                          list_options )
  32 import Darcs.ArgumentDefaults ( get_default_flags )
  33 import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),
  34                         DarcsCommand,
  35                         command_name,
  36                         command_command,
  37                         command_prereq,
  38                         command_extra_arg_help,
  39                         command_extra_args,
  40                         command_argdefaults,
  41                         command_get_arg_possibilities,
  42                         command_options, command_alloptions,
  43                         disambiguate_commands,
  44                         get_command_help, get_command_mini_help,
  45                         get_subcommands,
  46                         extract_commands,
  47                         super_name,
  48                         subusage, chomp_newline )
  49 import Darcs.Commands.Help ( command_control_list )
  50 import Darcs.External ( viewDoc )
  51 import Darcs.Global ( setDebugMode, setSshControlMasterDisabled,
  52                       setTimingsMode, setVerboseMode )
  53 import Darcs.Match ( checkMatchSyntax )
  54 import Darcs.Progress ( setProgressMode )
  55 import Darcs.RepoPath ( getCurrentDirectory )
  56 import Darcs.SignalHandler ( catchNonSignal )
  57 import Darcs.Test ( run_posthook, run_prehook )
  58 import Darcs.Utils ( formatPath )
  59 import Printer ( text )
  60 import URL ( setDebugHTTP, setHTTPPipelining )
  61
  62 run_the_command :: String -> [String] -> IO ()
  63 run_the_command cmd args =
  64   either fail rtc $ disambiguate_commands command_control_list cmd args
  65  where
  66   rtc (CommandOnly c, as)       = run_command Nothing c  as
  67   rtc (SuperCommandOnly c,  as) = run_raw_supercommand c as
  68   rtc (SuperCommandSub c s, as) = run_command (Just c) s as
  69 \end{code}
  70
  71 \begin{comment}
  72
  73 This is the actual heavy lifter code, which is responsible for parsing the
  74 arguments and then running the command itself.
  75
  76 \end{comment}
  77 \begin{code}
  78 run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()
  79
  80 run_command _ _ args -- Check for "dangerous" typoes...
  81     | "-all" `elem` args = -- -all indicates --all --look-for-adds!
  82         fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?"
  83 run_command msuper cmd args = do
  84    cwd <- getCurrentDirectory
  85    let options = opts1 ++ opts2
  86        (opts1, opts2) = command_options cwd cmd
  87    case getOpt Permute
  88              (option_from_darcsoption cwd list_options++options) args of
  89     (opts,extra,[])
  90       | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd
  91       | ListOptions `elem` opts  -> do
  92            setProgressMode False
  93            command_prereq cmd opts
  94            file_args <- command_get_arg_possibilities cmd
  95            putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args
  96       | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra
  97     (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
  98     where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts
  99                                  | otherwise = opts
 100
 101 consider_running :: Maybe DarcsCommand -> DarcsCommand
 102                  -> [DarcsFlag] -> [String] -> IO ()
 103 consider_running msuper cmd opts old_extra = do
 104  cwd <- getCurrentDirectory
 105  location <- command_prereq cmd opts
 106  case location of
 107    Left complaint -> fail $ "Unable to " ++
 108                      formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++
 109                      " here.\n\n" ++ complaint
 110    Right () -> do
 111     specops <- add_command_defaults cmd opts
 112     extra <- (command_argdefaults cmd) specops cwd old_extra
 113     when (Disable `elem` specops) $
 114       fail $ "Command "++command_name cmd++" disabled with --disable option!"
 115     if command_extra_args cmd < 0
 116       then runWithHooks specops extra
 117       else if length extra > command_extra_args cmd
 118            then fail $ "Bad argument: `"++unwords extra++"'\n"++
 119                        get_command_mini_help msuper cmd
 120            else if length extra < command_extra_args cmd
 121                 then fail $ "Missing argument:  " ++
 122                             nth_arg (length extra + 1) ++
 123                             "\n" ++ get_command_mini_help msuper cmd
 124                 else runWithHooks specops extra
 125        where nth_arg n = nth_of n (command_extra_arg_help cmd)
 126              nth_of 1 (h:_) = h
 127              nth_of n (_:hs) = nth_of (n-1) hs
 128              nth_of _ [] = "UNDOCUMENTED"
 129              runWithHooks os ex = do
 130                here <- getCurrentDirectory
 131                checkMatchSyntax os
 132                -- set any global variables
 133                when (Timings `elem` os) setTimingsMode
 134                when (Debug `elem` os) setDebugMode
 135                when (DebugHTTP `elem` os) setDebugHTTP
 136                when (Verbose `elem` os) setVerboseMode
 137                when (Quiet `elem` os) $ setProgressMode False
 138                when (HTTPPipelining `elem` os) $ setHTTPPipelining True
 139                when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False
 140                unless (SSHControlMaster `elem` os) setSshControlMasterDisabled
 141                -- actually run the command and its hooks
 142                preHookExitCode <- run_prehook os here
 143                if preHookExitCode /= ExitSuccess
 144                   then exitWith preHookExitCode
 145                   else do let fixFlag = FixFilePath here cwd
 146                           (command_command cmd) (fixFlag : os) ex
 147                             `catchNonSignal`
 148                             (\e -> case e of
 149                                      ExitException ExitSuccess -> return ()
 150                                      _ -> throwIO e)
 151                           postHookExitCode <- run_posthook os here
 152                           --
 153                           exitWith postHookExitCode
 154
 155 add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]
 156 add_command_defaults cmd already = do
 157   let (opts1, opts2) = command_alloptions cmd
 158   defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already
 159   return $ already ++ defaults
 160
 161 get_options_options :: [OptDescr DarcsFlag] -> String
 162 get_options_options [] = ""
 163 get_options_options (o:os) =
 164     get_long_option o ++"\n"++ get_options_options os
 165
 166 get_long_option :: OptDescr DarcsFlag -> String
 167 get_long_option (Option _ [] _ _) = ""
 168 get_long_option (Option a (o:os) b c) = "--"++o++
 169                  get_long_option (Option a os b c)
 170 \end{code}
 171
 172 \begin{code}
 173 run_raw_supercommand :: DarcsCommand -> [String] -> IO ()
 174 run_raw_supercommand super [] =
 175     fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"
 176              ++ subusage super
 177 run_raw_supercommand super args = do
 178   cwd <- getCurrentDirectory
 179   case getOpt RequireOrder
 180              (option_from_darcsoption cwd help++
 181               option_from_darcsoption cwd list_options) args of
 182     (opts,_,[])
 183       | Help `elem` opts ->
 184             viewDoc $ text $ get_command_help Nothing super
 185       | ListOptions `elem` opts -> do
 186             putStrLn "--help"
 187             mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super)
 188       | otherwise ->
 189             if Disable `elem` opts
 190             then fail $ "Command " ++ (command_name super) ++
 191                       " disabled with --disable option!"
 192             else fail $ "Invalid subcommand!\n\n" ++ subusage super
 193     (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
 194 \end{code}