module Darcs.UI.RunCommand ( runTheCommand ) where
import Prelude ()
import Darcs.Prelude
import Data.List ( intercalate )
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 ( (^), odesc, oparse, parseFlags, optDescr, (?) )
import Darcs.UI.Options.All
( stdCmdActions, StdCmdAction(..)
, anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..)
, HooksConfig(..), hooks )
import Darcs.UI.Defaults ( applyDefaults )
import Darcs.UI.External ( viewDoc )
import Darcs.UI.Flags ( DarcsFlag (NewRepo), matchAny, fixRemoteRepos )
import Darcs.UI.Commands
( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub )
, CommandControl
, DarcsCommand
, commandName
, commandCommand
, commandPrereq
, commandExtraArgHelp
, commandExtraArgs
, commandArgdefaults
, commandCompleteArgs
, commandOptions
, commandParseOptions
, wrappedCommandName
, disambiguateCommands
, getSubcommands
, extractCommands
, superName
)
import Darcs.UI.Commands.GZCRCs ( doCRCWarnings )
import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )
import Darcs.UI.Usage
( getCommandHelp
, getCommandMiniHelp
, subusage
)
import Darcs.Patch.Match ( checkMatchSyntax )
import Darcs.Repository.Prefs ( getGlobal, getPreflist )
import Darcs.Repository.Test ( runPosthook, runPrehook )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining )
import Darcs.Util.Exception ( die )
import Darcs.Util.Global ( setDebugMode, setTimingsMode )
import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )
import Darcs.Util.Progress ( setProgressMode )
import Darcs.Util.Text ( chompTrailingNewline, quote )
runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
runTheCommand commandControlList :: [CommandControl]
commandControlList cmd :: String
cmd args :: [String]
args =
(String -> IO ())
-> ((CommandArgs, [String]) -> IO ())
-> Either String (CommandArgs, [String])
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ()
forall a. String -> IO a
die (CommandArgs, [String]) -> IO ()
rtc (Either String (CommandArgs, [String]) -> IO ())
-> Either String (CommandArgs, [String]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [CommandControl]
-> String -> [String] -> Either String (CommandArgs, [String])
disambiguateCommands [CommandControl]
commandControlList String
cmd [String]
args
where
rtc :: (CommandArgs, [String]) -> IO ()
rtc (CommandOnly c :: DarcsCommand parsedFlags
c, as :: [String]
as) = Maybe (DarcsCommand Any)
-> DarcsCommand parsedFlags -> [String] -> IO ()
forall pf1 pf2.
Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()
runCommand Maybe (DarcsCommand Any)
forall a. Maybe a
Nothing DarcsCommand parsedFlags
c [String]
as
rtc (SuperCommandOnly c :: DarcsCommand parsedFlags
c, as :: [String]
as) = DarcsCommand parsedFlags -> [String] -> IO ()
forall pf. DarcsCommand pf -> [String] -> IO ()
runRawSupercommand DarcsCommand parsedFlags
c [String]
as
rtc (SuperCommandSub c :: DarcsCommand parsedFlags1
c s :: DarcsCommand parsedFlags2
s, as :: [String]
as) = Maybe (DarcsCommand parsedFlags1)
-> DarcsCommand parsedFlags2 -> [String] -> IO ()
forall pf1 pf2.
Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()
runCommand (DarcsCommand parsedFlags1 -> Maybe (DarcsCommand parsedFlags1)
forall a. a -> Maybe a
Just DarcsCommand parsedFlags1
c) DarcsCommand parsedFlags2
s [String]
as
runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()
runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()
runCommand _ _ args :: [String]
args
| "-all" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args =
String -> IO ()
forall a. String -> IO a
die "Are you sure you didn't mean --all rather than -all?"
runCommand msuper :: Maybe (DarcsCommand pf1)
msuper cmd :: DarcsCommand pf2
cmd args :: [String]
args = do
AbsolutePath
old_wd <- IO AbsolutePath
getCurrentDirectory
let options :: [OptDescr DarcsFlag]
options = AbsolutePath -> DarcsCommand pf2 -> [OptDescr DarcsFlag]
forall pf. AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]
commandOptions AbsolutePath
old_wd DarcsCommand pf2
cmd
case ([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String])
forall a b. (a, b, [String]) -> (a, b, [String])
fixupMsgs (([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String]))
-> ([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String])
forall a b. (a -> b) -> a -> b
$ ArgOrder DarcsFlag
-> [OptDescr DarcsFlag]
-> [String]
-> ([DarcsFlag], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder DarcsFlag
forall a. ArgOrder a
Permute [OptDescr DarcsFlag]
options [String]
args of
(cmdline_flags :: [DarcsFlag]
cmdline_flags,orig_extra :: [String]
orig_extra,getopt_errs :: [String]
getopt_errs) -> do
Either String ()
prereq_errors <- DarcsCommand pf2 -> [DarcsFlag] -> IO (Either String ())
forall parsedFlags.
DarcsCommand parsedFlags -> [DarcsFlag] -> IO (Either String ())
commandPrereq DarcsCommand pf2
cmd [DarcsFlag]
cmdline_flags
AbsolutePath
new_wd <- IO AbsolutePath
getCurrentDirectory
[String]
user_defs <- String -> IO [String]
getGlobal "defaults"
[String]
repo_defs <- String -> IO [String]
getPreflist "defaults"
let (flags :: [DarcsFlag]
flags,flag_errors :: [String]
flag_errors) =
Maybe String
-> DarcsCommand pf2
-> AbsolutePath
-> [String]
-> [String]
-> [DarcsFlag]
-> ([DarcsFlag], [String])
forall pf.
Maybe String
-> DarcsCommand pf
-> AbsolutePath
-> [String]
-> [String]
-> [DarcsFlag]
-> ([DarcsFlag], [String])
applyDefaults ((DarcsCommand pf1 -> String)
-> Maybe (DarcsCommand pf1) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DarcsCommand pf1 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName Maybe (DarcsCommand pf1)
msuper) DarcsCommand pf2
cmd AbsolutePath
old_wd [String]
user_defs [String]
repo_defs [DarcsFlag]
cmdline_flags
case (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe StdCmdAction))
-> [DarcsFlag] -> Maybe StdCmdAction
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe StdCmdAction)
stdCmdActions [DarcsFlag]
flags of
Just Help -> Doc -> IO ()
viewDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
forall pf1 pf2. Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelp Maybe (DarcsCommand pf1)
msuper DarcsCommand pf2
cmd
Just ListOptions -> do
Bool -> IO ()
setProgressMode Bool
False
[String]
possible_args <- DarcsCommand pf2
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
forall parsedFlags.
DarcsCommand parsedFlags
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
commandCompleteArgs DarcsCommand pf2
cmd (AbsolutePath
new_wd, AbsolutePath
old_wd) [DarcsFlag]
flags [String]
orig_extra
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [OptDescr DarcsFlag] -> [String]
optionList [OptDescr DarcsFlag]
options [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
possible_args
Just Disable ->
String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Command "String -> String -> String
forall a. [a] -> [a] -> [a]
++DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf2
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++" disabled with --disable option!"
Nothing -> case Either String ()
prereq_errors of
Left complaint :: String
complaint -> String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Unable to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote ("darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (DarcsCommand pf1) -> String
forall pf. Maybe (DarcsCommand pf) -> String
superName Maybe (DarcsCommand pf1)
msuper String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf2
cmd) String -> String -> String
forall a. [a] -> [a] -> [a]
++
" here.\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
complaint
Right () -> case [String]
getopt_errs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
flag_errors of
[] -> do
[String]
extra <- DarcsCommand pf2
-> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
forall parsedFlags.
DarcsCommand parsedFlags
-> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults DarcsCommand pf2
cmd [DarcsFlag]
flags AbsolutePath
old_wd [String]
orig_extra
case [String]
-> DarcsCommand pf2 -> Maybe (DarcsCommand pf1) -> Maybe String
forall pf1 pf2.
[String]
-> DarcsCommand pf1 -> Maybe (DarcsCommand pf2) -> Maybe String
extraArgumentsError [String]
extra DarcsCommand pf2
cmd Maybe (DarcsCommand pf1)
msuper of
Nothing -> DarcsCommand pf2
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
forall pf.
DarcsCommand pf
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
runWithHooks DarcsCommand pf2
cmd (AbsolutePath
new_wd, AbsolutePath
old_wd) [DarcsFlag]
flags [String]
extra
Just msg :: String
msg -> String -> IO ()
forall a. String -> IO a
die String
msg
es :: [String]
es -> String -> IO ()
forall a. String -> IO a
die (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
es)
fixupMsgs :: (a, b, [String]) -> (a, b, [String])
fixupMsgs :: (a, b, [String]) -> (a, b, [String])
fixupMsgs (fs :: a
fs,as :: b
as,es :: [String]
es) = (a
fs,b
as,(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (("command line: "String -> String -> String
forall a. [a] -> [a] -> [a]
++)(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
chompTrailingNewline) [String]
es)
runWithHooks :: DarcsCommand pf
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO ()
runWithHooks :: DarcsCommand pf
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
runWithHooks cmd :: DarcsCommand pf
cmd (new_wd :: AbsolutePath
new_wd, old_wd :: AbsolutePath
old_wd) flags :: [DarcsFlag]
flags extra :: [String]
extra = do
[MatchFlag] -> IO ()
checkMatchSyntax ([MatchFlag] -> IO ()) -> [MatchFlag] -> IO ()
forall a b. (a -> b) -> a -> b
$ MatchOption
matchAny MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
OptSpec
DarcsOptDescr
DarcsFlag
(IO ())
(Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ())
-> (Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ())
-> [DarcsFlag]
-> IO ()
forall (d :: * -> *) f a b. OptSpec d f a b -> b -> [f] -> a
oparse (DarcsOption
(NetworkOptions -> IO ())
(Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ())
forall a. DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)
anyVerbosity DarcsOption
(NetworkOptions -> IO ())
(Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ())
-> OptSpec
DarcsOptDescr DarcsFlag (IO ()) (NetworkOptions -> IO ())
-> OptSpec
DarcsOptDescr
DarcsFlag
(IO ())
(Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ())
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag (IO ()) (NetworkOptions -> IO ())
PrimDarcsOption NetworkOptions
network) Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()
setGlobalVariables [DarcsFlag]
flags
let hooksCfg :: HooksConfig
hooksCfg = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a HooksConfig)
-> [DarcsFlag] -> HooksConfig
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a HooksConfig
hooks [DarcsFlag]
flags
let verb :: Verbosity
verb = (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity)
-> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
verbosity [DarcsFlag]
flags
ExitCode
preHookExitCode <- HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPrehook (HooksConfig -> HookConfig
pre HooksConfig
hooksCfg) Verbosity
verb AbsolutePath
new_wd
if ExitCode
preHookExitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess
then ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
preHookExitCode
else do [DarcsFlag]
fixedFlags <- AbsolutePath -> [DarcsFlag] -> IO [DarcsFlag]
fixRemoteRepos AbsolutePath
old_wd [DarcsFlag]
flags
AbsolutePath
phDir <- AbsolutePath
-> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
forall pf.
AbsolutePath
-> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir AbsolutePath
new_wd DarcsCommand pf
cmd [DarcsFlag]
fixedFlags [String]
extra
let parsedFlags :: pf
parsedFlags = DarcsCommand pf -> [DarcsFlag] -> pf
forall parsedFlags.
DarcsCommand parsedFlags -> [DarcsFlag] -> parsedFlags
commandParseOptions DarcsCommand pf
cmd [DarcsFlag]
fixedFlags
DarcsCommand pf
-> (AbsolutePath, AbsolutePath) -> pf -> [String] -> IO ()
forall parsedFlags.
DarcsCommand parsedFlags
-> (AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO ()
commandCommand DarcsCommand pf
cmd (AbsolutePath
new_wd, AbsolutePath
old_wd) pf
parsedFlags [String]
extra
ExitCode
postHookExitCode <- HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPosthook (HooksConfig -> HookConfig
post HooksConfig
hooksCfg) Verbosity
verb AbsolutePath
phDir
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
postHookExitCode
setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()
setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()
setGlobalVariables debug :: Bool
debug debugHttp :: Bool
debugHttp verb :: Verbosity
verb timings :: Bool
timings net :: NetworkOptions
net = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
timings IO ()
setTimingsMode
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug IO ()
setDebugMode
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugHttp IO ()
setDebugHTTP
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
setProgressMode Bool
False
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NetworkOptions -> Bool
noHttpPipelining NetworkOptions
net) IO ()
disableHTTPPipelining
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
doCRCWarnings (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose)
getPosthookDir :: AbsolutePath -> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir :: AbsolutePath
-> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir new_wd :: AbsolutePath
new_wd cmd :: DarcsCommand pf
cmd flags :: [DarcsFlag]
flags extra :: [String]
extra | DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf
cmd String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["get","clone"] = do
case [String]
extra of
[inrepodir :: String
inrepodir, outname :: String
outname] -> AbsolutePath
-> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
forall pf.
AbsolutePath
-> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir AbsolutePath
new_wd DarcsCommand pf
cmd (String -> DarcsFlag
NewRepo String
outnameDarcsFlag -> [DarcsFlag] -> [DarcsFlag]
forall a. a -> [a] -> [a]
:[DarcsFlag]
flags) [String
inrepodir]
[inrepodir :: String
inrepodir] ->
case [DarcsFlag] -> Maybe String
cloneToSSH [DarcsFlag]
flags of
Nothing -> do
String
repodir <- AbsoluteOrRemotePath -> String
forall a. FilePathOrURL a => a -> String
toPath (AbsoluteOrRemotePath -> String)
-> IO AbsoluteOrRemotePath -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote String
inrepodir
String
reponame <- Bool -> [DarcsFlag] -> String -> IO String
makeRepoName Bool
False [DarcsFlag]
flags String
repodir
AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsolutePath -> IO AbsolutePath)
-> AbsolutePath -> IO AbsolutePath
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String -> AbsolutePath
makeAbsolute AbsolutePath
new_wd String
reponame
_ -> AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath
new_wd
_ -> String -> IO AbsolutePath
forall a. String -> IO a
die "You must provide 'clone' with either one or two arguments."
getPosthookDir new_wd :: AbsolutePath
new_wd _ _ _ = AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath
new_wd
extraArgumentsError :: [String]
-> DarcsCommand pf1
-> Maybe (DarcsCommand pf2)
-> Maybe String
extra :: [String]
extra cmd :: DarcsCommand pf1
cmd msuper :: Maybe (DarcsCommand pf2)
msuper
| Int
extraArgsCmd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Maybe String
forall a. Maybe a
Nothing
| Int
extraArgsInput Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
extraArgsCmd = String -> Maybe String
forall a. a -> Maybe a
Just String
badArg
| Int
extraArgsInput Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
extraArgsCmd = String -> Maybe String
forall a. a -> Maybe a
Just String
missingArg
| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
where
extraArgsInput :: Int
extraArgsInput = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
extra
extraArgsCmd :: Int
extraArgsCmd = DarcsCommand pf1 -> Int
forall parsedFlags. DarcsCommand parsedFlags -> Int
commandExtraArgs DarcsCommand pf1
cmd
badArg :: String
badArg = "Bad argument: `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extra String -> String -> String
forall a. [a] -> [a] -> [a]
++
"'\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (DarcsCommand pf2) -> DarcsCommand pf1 -> String
forall pf1 pf2.
Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
getCommandMiniHelp Maybe (DarcsCommand pf2)
msuper DarcsCommand pf1
cmd
missingArg :: String
missingArg = "Missing argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. (Eq t, Num t) => t -> String
nthArg ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
extra Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (DarcsCommand pf2) -> DarcsCommand pf1 -> String
forall pf1 pf2.
Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
getCommandMiniHelp Maybe (DarcsCommand pf2)
msuper DarcsCommand pf1
cmd
nthArg :: t -> String
nthArg n :: t
n = t -> [String] -> String
forall t. (Eq t, Num t) => t -> [String] -> String
nthOf t
n (DarcsCommand pf1 -> [String]
forall parsedFlags. DarcsCommand parsedFlags -> [String]
commandExtraArgHelp DarcsCommand pf1
cmd)
nthOf :: t -> [String] -> String
nthOf 1 (h :: String
h:_) = String
h
nthOf n :: t
n (_:hs :: [String]
hs) = t -> [String] -> String
nthOf (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [String]
hs
nthOf _ [] = "UNDOCUMENTED"
optionList :: [OptDescr DarcsFlag] -> [String]
optionList :: [OptDescr DarcsFlag] -> [String]
optionList = (OptDescr DarcsFlag -> [String])
-> [OptDescr DarcsFlag] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr DarcsFlag -> [String]
forall a. OptDescr a -> [String]
names
where
names :: OptDescr a -> [String]
names (Option sos :: String
sos los :: [String]
los _ desc :: String
desc) =
(Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Char -> String
short String
desc) String
sos [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
long String
desc) [String]
los
short :: String -> Char -> String
short d :: String
d o :: Char
o = '-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
o Char -> String -> String
forall a. a -> [a] -> [a]
: ";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d
long :: String -> String -> String
long d :: String
d o :: String
o = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d
runRawSupercommand :: DarcsCommand pf -> [String] -> IO ()
runRawSupercommand :: DarcsCommand pf -> [String] -> IO ()
runRawSupercommand super :: DarcsCommand pf
super [] =
String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Command '"String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf
super String -> String -> String
forall a. [a] -> [a] -> [a]
++"' requires a subcommand!\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
subusage DarcsCommand pf
super
runRawSupercommand super :: DarcsCommand pf
super args :: [String]
args = do
AbsolutePath
cwd <- IO AbsolutePath
getCurrentDirectory
case ([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String])
forall a b. (a, b, [String]) -> (a, b, [String])
fixupMsgs (([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String]))
-> ([DarcsFlag], [String], [String])
-> ([DarcsFlag], [String], [String])
forall a b. (a -> b) -> a -> b
$ ArgOrder DarcsFlag
-> [OptDescr DarcsFlag]
-> [String]
-> ([DarcsFlag], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder DarcsFlag
forall a. ArgOrder a
RequireOrder ((DarcsOptDescr DarcsFlag -> OptDescr DarcsFlag)
-> [DarcsOptDescr DarcsFlag] -> [OptDescr DarcsFlag]
forall a b. (a -> b) -> [a] -> [b]
map (AbsolutePath -> DarcsOptDescr DarcsFlag -> OptDescr DarcsFlag
forall f. AbsolutePath -> DarcsOptDescr f -> OptDescr f
optDescr AbsolutePath
cwd) (OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe StdCmdAction)
stdCmdActions)) [String]
args of
(flags :: [DarcsFlag]
flags,_,getopt_errs :: [String]
getopt_errs) -> case (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe StdCmdAction))
-> [DarcsFlag] -> Maybe StdCmdAction
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe StdCmdAction)
stdCmdActions [DarcsFlag]
flags of
Just Help ->
Doc -> IO ()
viewDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (DarcsCommand Any) -> DarcsCommand pf -> Doc
forall pf1 pf2. Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelp Maybe (DarcsCommand Any)
forall a. Maybe a
Nothing DarcsCommand pf
super
Just ListOptions -> do
String -> IO ()
putStrLn "--help"
(WrappedCommand -> IO ()) -> [WrappedCommand] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ())
-> (WrappedCommand -> String) -> WrappedCommand -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedCommand -> String
wrappedCommandName) ([CommandControl] -> [WrappedCommand]
extractCommands ([CommandControl] -> [WrappedCommand])
-> [CommandControl] -> [WrappedCommand]
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf -> [CommandControl]
forall pf. DarcsCommand pf -> [CommandControl]
getSubcommands DarcsCommand pf
super)
Just Disable -> do
String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Command " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf
super String -> String -> String
forall a. [a] -> [a] -> [a]
++
" disabled with --disable option!"
Nothing -> String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case [String]
getopt_errs of
[] -> "Invalid subcommand!\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
subusage DarcsCommand pf
super
_ -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
getopt_errs