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