-- Copyright (C) 2002,2003,2005 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE OverloadedStrings #-}
-- | This is the actual heavy lifter code, which is responsible for parsing the
-- arguments and then running the command itself.
module Darcs.UI.RunCommand
  ( runTheCommand
  , runWithHooks -- exported for darcsden
  ) 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 =
  (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 DarcsCommand
c,       [String]
as) = Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()
runCommand Maybe DarcsCommand
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 (DarcsCommand -> Maybe DarcsCommand
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 -- Check for "dangerous" typoes...
    | String
"-all" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args = -- -all indicates --all --look-for-adds!
        String -> IO ()
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 ([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
    ([DarcsFlag]
cmdline_flags,[String]
orig_extra,[String]
getopt_errs) -> do
      -- FIXME This code is highly order-dependent because of hidden state: the
      -- current directory. Like almost all Repository functions, getGlobal and
      -- getPreflist assume that the cwd is the base of our work repo (if any).
      -- This is supposed to be ensured by commandPrereq. Which means we must
      -- first call commandPrereq, then getGlobal and getPreflist, and then we
      -- must use the (saved) original working directory to resolve possibly
      -- relative paths to absolute paths.
      Either String ()
prereq_errors <- DarcsCommand -> [DarcsFlag] -> IO (Either String ())
commandPrereq DarcsCommand
cmd [DarcsFlag]
cmdline_flags
      -- we must get the cwd again because commandPrereq has the side-effect of changing it.
      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 ((DarcsCommand -> String) -> Maybe DarcsCommand -> Maybe String
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 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 StdCmdAction
Help -> Doc -> IO ()
viewDoc (Doc -> IO ()) -> Doc -> IO ()
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
          (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 StdCmdAction
Disable ->
          String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Command "String -> String -> String
forall a. [a] -> [a] -> [a]
++DarcsCommand -> String
commandName DarcsCommand
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" disabled with --disable option!"
        Maybe StdCmdAction
Nothing -> case Either String ()
prereq_errors of
          Left String
complaint -> String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Unable to '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DarcsCommand -> String
superName Maybe DarcsCommand
msuper String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand -> String
commandName DarcsCommand
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"' here:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
complaint
          Right () -> do
            Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [String]
getopt_errs [String] -> [String] -> [String]
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    -> String -> IO ()
forall a. String -> IO a
die String
msg

fixupMsgs :: (a, b, [String]) -> (a, b, [String])
fixupMsgs :: (a, b, [String]) -> (a, b, [String])
fixupMsgs (a
fs,b
as,[String]
es) = (a
fs,b
as,(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"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)
  where
    chompTrailingNewline :: String -> String
chompTrailingNewline String
"" = String
""
    chompTrailingNewline String
s = if String -> Char
forall a. [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then String -> String
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 ([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
   -- set any global variables
   OptSpec
  DarcsOptDescr
  DarcsFlag
  (IO ())
  (Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ())
-> (Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ())
-> [DarcsFlag]
-> IO ()
forall (d :: * -> *) f a b. OptSpec d f a b -> b -> [f] -> a
oparse (PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Bool -> Bool -> NetworkOptions -> IO ())
  Verbosity
PrimDarcsOption Verbosity
verbosity PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Bool -> Bool -> NetworkOptions -> IO ())
  Verbosity
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (NetworkOptions -> IO ())
     (Bool -> Bool -> Bool -> NetworkOptions -> IO ())
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (NetworkOptions -> IO ())
     (Verbosity -> Bool -> Bool -> 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
  (NetworkOptions -> IO ())
  (Bool -> Bool -> Bool -> NetworkOptions -> IO ())
forall a. DarcsOption a (Bool -> Bool -> Bool -> a)
debugging OptSpec
  DarcsOptDescr
  DarcsFlag
  (NetworkOptions -> IO ())
  (Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ())
-> OptSpec
     DarcsOptDescr DarcsFlag (IO ()) (NetworkOptions -> IO ())
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (IO ())
     (Verbosity -> Bool -> Bool -> 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) Verbosity -> Bool -> Bool -> Bool -> NetworkOptions -> IO ()
setGlobalVariables [DarcsFlag]
flags
   -- actually run the command and its hooks
   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 = PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
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 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 -> [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
              ExitCode -> IO ()
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
  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)

-- | Returns the working directory for the posthook. For most commands, the
-- first parameter is returned. For the \'get\' command, the path of the newly
-- created repository is returned if it is not an ssh url.
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 String -> [String] -> Bool
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 <- 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
newRepo <- 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
newRepo
         Maybe String
_ -> AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath
new_wd
      [String]
_ -> String -> IO AbsolutePath
forall a. String -> IO a
die String
"You must provide 'clone' with either one or two arguments."
getPosthookDir AbsolutePath
new_wd DarcsCommand
_ [DarcsFlag]
_ [String]
_ = AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath
new_wd


-- | Checks if the number of extra arguments matches the number of extra
-- arguments supported by the command as specified in `commandExtraArgs`.
-- Extra arguments are arguments that follow the command but aren't
-- considered a flag. In `darcs push xyz`, xyz would be an extra argument.
extraArgumentsError :: [String]             -- extra commands provided by user
                    -> DarcsCommand
                    -> Maybe DarcsCommand
                    -> Maybe String
extraArgumentsError :: [String] -> DarcsCommand -> Maybe DarcsCommand -> Maybe String
extraArgumentsError [String]
extra DarcsCommand
cmd Maybe DarcsCommand
msuper
    | Int
extraArgsCmd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 -> Int
commandExtraArgs DarcsCommand
cmd
            badArg :: String
badArg     = String
"Bad argument: `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extra String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
"'\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DarcsCommand -> DarcsCommand -> String
getCommandMiniHelp Maybe DarcsCommand
msuper DarcsCommand
cmd
            missingArg :: String
missingArg = String
"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
+ Int
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe DarcsCommand -> DarcsCommand -> String
getCommandMiniHelp Maybe DarcsCommand
msuper DarcsCommand
cmd
            nthArg :: t -> String
nthArg t
n       = t -> [String] -> String
forall t p. (Eq t, Num t, IsString p) => t -> [p] -> p
nthOf t
n (DarcsCommand -> [String]
commandExtraArgHelp DarcsCommand
cmd)
            nthOf :: t -> [p] -> p
nthOf t
1 (p
h:[p]
_)  = p
h
            nthOf t
n (p
_:[p]
hs) = t -> [p] -> p
nthOf (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [p]
hs
            nthOf t
_ []     = p
"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 String
sos [String]
los ArgDescr a
_ 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 String
d Char
o = Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
o Char -> String -> String
forall a. a -> [a] -> [a]
: String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d
    long :: String -> String -> String
long String
d String
o = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d

runRawSupercommand :: DarcsCommand -> [String] -> IO ()
runRawSupercommand :: DarcsCommand -> [String] -> IO ()
runRawSupercommand DarcsCommand
super [] =
  String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
    Doc
"Command '" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (DarcsCommand -> String
commandName DarcsCommand
super) Doc -> Doc -> Doc
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 ([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
    -- note: we do not apply defaults here
    ([DarcsFlag]
flags,[String]
_,[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 StdCmdAction
Help ->
        Doc -> IO ()
viewDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelp Maybe DarcsCommand
forall a. Maybe a
Nothing DarcsCommand
super
      Just StdCmdAction
ListOptions -> do
        String -> IO ()
putStrLn String
"--help"
        (DarcsCommand -> IO ()) -> [DarcsCommand] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ())
-> (DarcsCommand -> String) -> DarcsCommand -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand -> String
commandName) ([CommandControl] -> [DarcsCommand]
extractCommands ([CommandControl] -> [DarcsCommand])
-> [CommandControl] -> [DarcsCommand]
forall a b. (a -> b) -> a -> b
$ DarcsCommand -> [CommandControl]
getSubcommands DarcsCommand
super)
      Just StdCmdAction
Disable -> do
        String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
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 ->
        String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
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 ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
getopt_errs)