module Darcs.RunCommand ( run_the_command ) where
import Control.Monad ( unless, when )
import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),
OptDescr( Option ),
getOpt )
import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
import Darcs.Arguments ( DarcsFlag(..),
help,
option_from_darcsoption,
list_options )
import Darcs.ArgumentDefaults ( get_default_flags )
import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),
DarcsCommand,
command_name,
command_command,
command_prereq,
command_extra_arg_help,
command_extra_args,
command_argdefaults,
command_get_arg_possibilities,
command_options, command_alloptions,
disambiguate_commands,
get_command_help, get_command_mini_help,
get_subcommands,
extract_commands,
super_name,
subusage, chomp_newline )
import Darcs.Commands.Help ( command_control_list )
import Darcs.External ( viewDoc )
import Darcs.Global ( setDebugMode, setSshControlMasterDisabled,
setTimingsMode, setVerboseMode )
import Darcs.Match ( checkMatchSyntax )
import Progress ( setProgressMode )
import Darcs.RepoPath ( getCurrentDirectory )
import Darcs.Test ( run_posthook, run_prehook )
import Darcs.Utils ( formatPath )
import Printer ( text )
import URL ( setDebugHTTP, setHTTPPipelining )
run_the_command :: String -> [String] -> IO ()
run_the_command cmd args =
either fail rtc $ disambiguate_commands command_control_list cmd args
where
rtc (CommandOnly c, as) = run_command Nothing c as
rtc (SuperCommandOnly c, as) = run_raw_supercommand c as
rtc (SuperCommandSub c s, as) = run_command (Just c) s as
run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()
run_command _ _ args
| "-all" `elem` args =
fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?"
run_command msuper cmd args = do
cwd <- getCurrentDirectory
let options = opts1 ++ opts2
(opts1, opts2) = command_options cwd cmd
case getOpt Permute
(option_from_darcsoption cwd list_options++options) args of
(opts,extra,[])
| Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd
| ListOptions `elem` opts -> do
setProgressMode False
command_prereq cmd opts
file_args <- command_get_arg_possibilities cmd
putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args
| otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra
(_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts
| otherwise = opts
consider_running :: Maybe DarcsCommand -> DarcsCommand
-> [DarcsFlag] -> [String] -> IO ()
consider_running msuper cmd opts old_extra = do
cwd <- getCurrentDirectory
location <- command_prereq cmd opts
case location of
Left complaint -> fail $ "Unable to " ++
formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++
" here.\n\n" ++ complaint
Right () -> do
specops <- add_command_defaults cmd opts
extra <- (command_argdefaults cmd) specops cwd old_extra
when (Disable `elem` specops) $
fail $ "Command "++command_name cmd++" disabled with --disable option!"
if command_extra_args cmd < 0
then runWithHooks specops extra
else if length extra > command_extra_args cmd
then fail $ "Bad argument: `"++unwords extra++"'\n"++
get_command_mini_help msuper cmd
else if length extra < command_extra_args cmd
then fail $ "Missing argument: " ++
nth_arg (length extra + 1) ++
"\n" ++ get_command_mini_help msuper cmd
else runWithHooks specops extra
where nth_arg n = nth_of n (command_extra_arg_help cmd)
nth_of 1 (h:_) = h
nth_of n (_:hs) = nth_of (n1) hs
nth_of _ [] = "UNDOCUMENTED"
runWithHooks os ex = do
here <- getCurrentDirectory
checkMatchSyntax os
when (Timings `elem` os) setTimingsMode
when (Debug `elem` os) setDebugMode
when (DebugHTTP `elem` os) setDebugHTTP
when (Verbose `elem` os) setVerboseMode
when (Quiet `elem` os) $ setProgressMode False
when (HTTPPipelining `elem` os) $ setHTTPPipelining True
when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False
unless (SSHControlMaster `elem` os) setSshControlMasterDisabled
preHookExitCode <- run_prehook os here
if preHookExitCode /= ExitSuccess
then exitWith preHookExitCode
else do let fixFlag = FixFilePath here cwd
(command_command cmd) (fixFlag : os) ex
postHookExitCode <- run_posthook os here
exitWith postHookExitCode
add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]
add_command_defaults cmd already = do
let (opts1, opts2) = command_alloptions cmd
defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already
return $ already ++ defaults
get_options_options :: [OptDescr DarcsFlag] -> String
get_options_options [] = ""
get_options_options (o:os) =
get_long_option o ++"\n"++ get_options_options os
get_long_option :: OptDescr DarcsFlag -> String
get_long_option (Option _ [] _ _) = ""
get_long_option (Option a (o:os) b c) = "--"++o++
get_long_option (Option a os b c)
run_raw_supercommand :: DarcsCommand -> [String] -> IO ()
run_raw_supercommand super [] =
fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"
++ subusage super
run_raw_supercommand super args = do
cwd <- getCurrentDirectory
case getOpt RequireOrder
(option_from_darcsoption cwd help++
option_from_darcsoption cwd list_options) args of
(opts,_,[])
| Help `elem` opts ->
viewDoc $ text $ get_command_help Nothing super
| ListOptions `elem` opts -> do
putStrLn "--help"
mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super)
| otherwise ->
if Disable `elem` opts
then fail $ "Command " ++ (command_name super) ++
" disabled with --disable option!"
else fail $ "Invalid subcommand!\n\n" ++ subusage super
(_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)