module Darcs.UI.RunCommand ( runTheCommand ) where
import Prelude hiding ( (^) )
import Data.Functor ((<$>))
import Control.Monad ( unless, when )
import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),
OptDescr( Option ),
getOpt )
import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
import Darcs.UI.Options ( DarcsOption, (^), odesc, oparse, parseFlags, optDescr )
import Darcs.UI.Options.All
( stdCmdActions, StdCmdAction(..)
, anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..)
, preHook, postHook )
import Darcs.UI.Defaults ( applyDefaults )
import Darcs.UI.Flags ( DarcsFlag (NewRepo), toMatchFlags, fixRemoteRepos )
import Darcs.UI.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),
CommandControl,
DarcsCommand,
commandName,
commandCommand,
commandPrereq,
commandExtraArgHelp,
commandExtraArgs,
commandArgdefaults,
commandGetArgPossibilities,
commandOptions,
commandParseOptions,
wrappedCommandName,
disambiguateCommands,
getCommandHelp, getCommandMiniHelp,
getSubcommands,
extractCommands,
superName,
subusage
, formatPath
)
import Darcs.UI.Commands.GZCRCs ( doCRCWarnings )
import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )
import Darcs.UI.External ( viewDoc )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Global ( setDebugMode, setTimingsMode )
import Darcs.Patch.Match ( checkMatchSyntax )
import Darcs.Util.Progress ( setProgressMode )
import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )
import Darcs.Repository.Test ( runPosthook, runPrehook )
import Data.List ( intercalate )
import Darcs.Util.Printer ( text )
import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining )
import Darcs.Util.Text ( chompTrailingNewline )
runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
runTheCommand commandControlList cmd args =
either fail rtc $ disambiguateCommands commandControlList cmd args
where
rtc (CommandOnly c, as) = runCommand Nothing c as
rtc (SuperCommandOnly c, as) = runRawSupercommand c as
rtc (SuperCommandSub c s, as) = runCommand (Just c) s as
runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()
runCommand _ _ args
| "-all" `elem` args =
fail "Are you sure you didn't mean --all rather than -all?"
runCommand msuper cmd args = do
old_wd <- getCurrentDirectory
let options = commandOptions old_wd cmd
case getOpt Permute options args of
(cmdline_flags,orig_extra,[]) -> do
prereq_errors <- commandPrereq cmd cmdline_flags
flags <- applyDefaults (fmap commandName msuper) cmd cmdline_flags
case parseFlags stdCmdActions flags of
Just Help -> viewDoc $ text $ getCommandHelp msuper cmd
Just ListOptions -> do
setProgressMode False
file_args <- commandGetArgPossibilities cmd
putStrLn $ unlines $ getOptionsOptions options : file_args
Just Disable ->
fail $ "Command "++commandName cmd++" disabled with --disable option!"
Nothing -> case prereq_errors of
Left complaint -> fail $
"Unable to " ++ formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++
" here.\n\n" ++ complaint
Right () -> do
extra <- commandArgdefaults cmd flags old_wd orig_extra
case extraArgumentsError extra cmd msuper of
Nothing -> runWithHooks cmd old_wd flags extra
Just msg -> fail msg
(_,_,ermsgs) -> fail $ chompTrailingNewline(unlines ermsgs)
withHookOpts :: DarcsOption a (t2 -> t3 -> t4 -> t1)
-> (t2 -> t3 -> t4 -> t -> t1) -> [DarcsFlag] -> t -> a
withHookOpts opts runHook flags path = oparse opts runHook' flags where
runHook' mcmd ask verb = runHook mcmd ask verb path
runWithHooks :: DarcsCommand pf
-> AbsolutePath -> [DarcsFlag] -> [String] -> IO ()
runWithHooks cmd old_wd flags extra = do
new_wd <- getCurrentDirectory
checkMatchSyntax $ toMatchFlags flags
oparse (anyVerbosity ^ network) setGlobalVariables flags
preHookExitCode <- withHookOpts (preHook ^ verbosity) runPrehook flags new_wd
if preHookExitCode /= ExitSuccess
then exitWith preHookExitCode
else do fixedFlags <- fixRemoteRepos old_wd flags
phDir <- getPosthookDir new_wd cmd fixedFlags extra
let parsedFlags = commandParseOptions cmd fixedFlags
commandCommand cmd (new_wd, old_wd) parsedFlags extra
postHookExitCode <- withHookOpts (postHook ^ verbosity) runPosthook flags phDir
exitWith postHookExitCode
setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()
setGlobalVariables debug debugHttp verb timings net = do
when timings setTimingsMode
when debug setDebugMode
when debugHttp setDebugHTTP
when (verb == Quiet) $ setProgressMode False
when (noHttpPipelining net) disableHTTPPipelining
unless (verb == Quiet) $ atexit $ doCRCWarnings (verb == Verbose)
getPosthookDir :: AbsolutePath -> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir new_wd cmd flags extra | commandName cmd `elem` ["get","clone"] = do
case extra of
[inrepodir, outname] -> getPosthookDir new_wd cmd (NewRepo outname:flags) [inrepodir]
[inrepodir] ->
case cloneToSSH flags of
Nothing -> do
repodir <- toPath <$> ioAbsoluteOrRemote inrepodir
reponame <- makeRepoName False flags repodir
return $ makeAbsolute new_wd reponame
_ -> return new_wd
_ -> fail "You must provide 'clone' with either one or two arguments."
getPosthookDir new_wd _ _ _ = return new_wd
extraArgumentsError :: [String]
-> DarcsCommand pf1
-> Maybe (DarcsCommand pf2)
-> Maybe String
extraArgumentsError extra cmd msuper
| extraArgsCmd < 0 = Nothing
| extraArgsInput > extraArgsCmd = Just badArg
| extraArgsInput < extraArgsCmd = Just missingArg
| otherwise = Nothing
where
extraArgsInput = length extra
extraArgsCmd = commandExtraArgs cmd
badArg = "Bad argument: `" ++ unwords extra ++
"'\n" ++ getCommandMiniHelp msuper cmd
missingArg = "Missing argument: " ++ nthArg (length extra + 1) ++
"\n" ++ getCommandMiniHelp msuper cmd
nthArg n = nthOf n (commandExtraArgHelp cmd)
nthOf 1 (h:_) = h
nthOf n (_:hs) = nthOf (n1) hs
nthOf _ [] = "UNDOCUMENTED"
getOptionsOptions :: [OptDescr DarcsFlag] -> String
getOptionsOptions = intercalate "\n" . concatMap goo
where
goo (Option _ os _ _) = map ("--"++) os
runRawSupercommand :: DarcsCommand pf -> [String] -> IO ()
runRawSupercommand super [] =
fail $ "Command '"++ commandName super ++"' requires a subcommand!\n\n"
++ subusage super
runRawSupercommand super args = do
cwd <- getCurrentDirectory
case getOpt RequireOrder (map (optDescr cwd) (odesc stdCmdActions)) args of
(flags,_,[]) -> case parseFlags stdCmdActions flags of
Just Help ->
viewDoc $ text $ getCommandHelp Nothing super
Just ListOptions -> do
putStrLn "--help"
mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super)
Just Disable -> do
fail $ "Command " ++ commandName super ++
" disabled with --disable option!"
Nothing ->
fail $ "Invalid subcommand!\n\n" ++ subusage super
(_,_,ermsgs) -> fail $ chompTrailingNewline(unlines ermsgs)