module Darcs.UI.Defaults ( applyDefaults ) where

import Darcs.Prelude

import Control.Monad.Writer
import Data.Char ( isSpace )
import Data.Functor.Compose ( Compose(..) )
import Data.List ( nub )
import Data.Maybe ( catMaybes )
import qualified Data.Map as M
import System.Console.GetOpt
import Text.Regex.Applicative
    ( (<|>)
    , match, many, some
    , psym, anySym, string )

import Darcs.UI.Flags ( DarcsFlag )
import Darcs.UI.Options ( DarcsOptDescr )

import Darcs.UI.Commands
    ( DarcsCommand(..), commandAlloptions, extractAllCommands
    )
import Darcs.UI.TheCommands ( commandControlList )
import Darcs.Util.Path ( AbsolutePath )

-- | Apply defaults from all sources to a list of 'DarcsFlag's (e.g. from the
-- command line), given the command (and possibly super command) name, and a
-- list of all options for the command.
-- 
-- Sources for defaults are
-- 
--  * the builtin (hard-coded) defaults,
-- 
--  * the defaults file in the user's configuration, and
-- 
--  * the defaults file in the current repository.
-- 
-- Note that the pseudo command @ALL@ is allowed in defaults files to specify
-- that an option should be the default for all commands to which it applies.
-- 
-- The order of precedence for conflicting options (i.e. those belonging to
-- same group of mutually exclusive options) is from less specific to more
-- specific. In other words, options from the command line override all
-- defaults, per-repo defaults override per-user defaults, which in turn
-- override the built-in defaults. Inside the options from a defaults file,
-- options for the given command override options for the @ALL@ pseudo command.
-- 
-- Conflicting options at the same level of precedence are not allowed.
--
-- Errors encountered during processing of command line or defaults flags
-- are formatted and added as (separate) strings to the list of error messages
-- that are returned together with the resulting flag list.
applyDefaults :: Maybe String -- ^ maybe name of super command
              -> DarcsCommand -- ^ the darcs command
              -> AbsolutePath -- ^ the original working directory, i.e.
                              --   the one from which darcs was invoked
              -> [String]     -- ^ lines from user defaults
              -> [String]     -- ^ lines from repo defaults
              -> [DarcsFlag]  -- ^ flags from command line
              -> ([DarcsFlag], [String]) -- new flags and errors
applyDefaults :: Maybe String
-> DarcsCommand
-> AbsolutePath
-> [String]
-> [String]
-> [DarcsFlag]
-> ([DarcsFlag], [String])
applyDefaults Maybe String
msuper DarcsCommand
cmd AbsolutePath
cwd [String]
user [String]
repo [DarcsFlag]
flags = Writer [String] [DarcsFlag] -> ([DarcsFlag], [String])
forall w a. Writer w a -> (a, w)
runWriter (Writer [String] [DarcsFlag] -> ([DarcsFlag], [String]))
-> Writer [String] [DarcsFlag] -> ([DarcsFlag], [String])
forall a b. (a -> b) -> a -> b
$ do
    [DarcsFlag]
cl_flags  <- String
-> ([DarcsFlag] -> [String])
-> [DarcsFlag]
-> Writer [String] [DarcsFlag]
runChecks String
"Command line" [DarcsFlag] -> [String]
check_opts [DarcsFlag]
flags
    [DarcsFlag]
user_defs <- String -> [String] -> Writer [String] [DarcsFlag]
get_flags String
"User defaults" [String]
user
    [DarcsFlag]
repo_defs <- String -> [String] -> Writer [String] [DarcsFlag]
get_flags String
"Repo defaults" [String]
repo
    [DarcsFlag] -> Writer [String] [DarcsFlag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DarcsFlag] -> Writer [String] [DarcsFlag])
-> [DarcsFlag] -> Writer [String] [DarcsFlag]
forall a b. (a -> b) -> a -> b
$ [DarcsFlag]
cl_flags [DarcsFlag] -> [DarcsFlag] -> [DarcsFlag]
forall a. [a] -> [a] -> [a]
++ [DarcsFlag]
repo_defs [DarcsFlag] -> [DarcsFlag] -> [DarcsFlag]
forall a. [a] -> [a] -> [a]
++ [DarcsFlag]
user_defs [DarcsFlag] -> [DarcsFlag] -> [DarcsFlag]
forall a. [a] -> [a] -> [a]
++ [DarcsFlag]
builtin_defs
  where
    cmd_name :: CmdName
cmd_name = Maybe String -> String -> CmdName
mkCmdName Maybe String
msuper (DarcsCommand -> String
commandName DarcsCommand
cmd)
    builtin_defs :: [DarcsFlag]
builtin_defs = DarcsCommand -> [DarcsFlag]
commandDefaults DarcsCommand
cmd
    check_opts :: [DarcsFlag] -> [String]
check_opts = DarcsCommand -> [DarcsFlag] -> [String]
commandCheckOptions DarcsCommand
cmd
    opts :: [DarcsOptDescr DarcsFlag]
opts = ([DarcsOptDescr DarcsFlag]
 -> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag])
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
-> [DarcsOptDescr DarcsFlag]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
(++) (([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
 -> [DarcsOptDescr DarcsFlag])
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
-> [DarcsOptDescr DarcsFlag]
forall a b. (a -> b) -> a -> b
$ DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand
cmd
    get_flags :: String -> [String] -> Writer [String] [DarcsFlag]
get_flags String
source = String
-> AbsolutePath
-> CmdName
-> [DarcsOptDescr DarcsFlag]
-> ([DarcsFlag] -> [String])
-> [String]
-> Writer [String] [DarcsFlag]
parseDefaults String
source AbsolutePath
cwd CmdName
cmd_name [DarcsOptDescr DarcsFlag]
opts [DarcsFlag] -> [String]
check_opts

-- | Name of a normal command, or name of super and sub command.
data CmdName = NormalCmd String | SuperCmd String String

-- | Make a 'CmdName' from a possible super command name and a sub command name.
mkCmdName :: Maybe String -> String -> CmdName
mkCmdName :: Maybe String -> String -> CmdName
mkCmdName Maybe String
Nothing String
cmd = String -> CmdName
NormalCmd String
cmd
mkCmdName (Just String
super) String
sub = String -> String -> CmdName
SuperCmd String
super String
sub

-- | Turn a 'CmdName' into a 'String'. For a 'SuperCmd' concatenate with a space in between.
showCmdName :: CmdName -> String
showCmdName :: CmdName -> String
showCmdName (SuperCmd String
super String
sub) = [String] -> String
unwords [String
super,String
sub]
showCmdName (NormalCmd String
name) = String
name

runChecks :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Writer [String] [DarcsFlag]
runChecks :: String
-> ([DarcsFlag] -> [String])
-> [DarcsFlag]
-> Writer [String] [DarcsFlag]
runChecks String
source [DarcsFlag] -> [String]
check [DarcsFlag]
fs = do
  [String] -> WriterT [String] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([String] -> WriterT [String] Identity ())
-> [String] -> WriterT [String] Identity ()
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": ")String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [DarcsFlag] -> [String]
check [DarcsFlag]
fs
  [DarcsFlag] -> Writer [String] [DarcsFlag]
forall (m :: * -> *) a. Monad m => a -> m a
return [DarcsFlag]
fs

-- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag',
-- given the current working directory, the command name, and a list of 'DarcsOption'
-- for the command.
--
-- In the result, defaults for the given command come first, then come defaults
-- for @ALL@ commands.
--
-- We check that matching options actually exist.
--
--  * lines matching the command name: the option must exist in the command's
--    option map.
--
--  * lines matching @ALL@: there must be at least *some* darcs command with
--    that option.
--
parseDefaults :: String
              -> AbsolutePath
              -> CmdName
              -> [DarcsOptDescr DarcsFlag]
              -> ([DarcsFlag] -> [String])
              -> [String]
              -> Writer [String] [DarcsFlag]
parseDefaults :: String
-> AbsolutePath
-> CmdName
-> [DarcsOptDescr DarcsFlag]
-> ([DarcsFlag] -> [String])
-> [String]
-> Writer [String] [DarcsFlag]
parseDefaults String
source AbsolutePath
cwd CmdName
cmd [DarcsOptDescr DarcsFlag]
opts [DarcsFlag] -> [String]
check_opts [String]
def_lines = do
    [DarcsFlag]
cmd_flags <- [String] -> [(String, String)] -> Writer [String] [DarcsFlag]
forall (t :: * -> *).
Foldable t =>
t String -> [(String, String)] -> Writer [String] [DarcsFlag]
flags_for (Map String (DarcsOptDescr DarcsFlag) -> [String]
forall k a. Map k a -> [k]
M.keys Map String (DarcsOptDescr DarcsFlag)
opt_map) [(String, String)]
cmd_defs Writer [String] [DarcsFlag]
-> ([DarcsFlag] -> Writer [String] [DarcsFlag])
-> Writer [String] [DarcsFlag]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      String
-> ([DarcsFlag] -> [String])
-> [DarcsFlag]
-> Writer [String] [DarcsFlag]
runChecks (String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" for command '"String -> String -> String
forall a. [a] -> [a] -> [a]
++CmdName -> String
showCmdName CmdName
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") [DarcsFlag] -> [String]
check_opts
    [DarcsFlag]
all_flags <- [String] -> [(String, String)] -> Writer [String] [DarcsFlag]
forall (t :: * -> *).
Foldable t =>
t String -> [(String, String)] -> Writer [String] [DarcsFlag]
flags_for [String]
allOptionSwitches [(String, String)]
all_defs Writer [String] [DarcsFlag]
-> ([DarcsFlag] -> Writer [String] [DarcsFlag])
-> Writer [String] [DarcsFlag]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      String
-> ([DarcsFlag] -> [String])
-> [DarcsFlag]
-> Writer [String] [DarcsFlag]
runChecks (String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" for ALL commands") [DarcsFlag] -> [String]
check_opts
    [DarcsFlag] -> Writer [String] [DarcsFlag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DarcsFlag] -> Writer [String] [DarcsFlag])
-> [DarcsFlag] -> Writer [String] [DarcsFlag]
forall a b. (a -> b) -> a -> b
$ [DarcsFlag]
cmd_flags [DarcsFlag] -> [DarcsFlag] -> [DarcsFlag]
forall a. [a] -> [a] -> [a]
++ [DarcsFlag]
all_flags
  where
    opt_map :: Map String (DarcsOptDescr DarcsFlag)
opt_map = [DarcsOptDescr DarcsFlag] -> Map String (DarcsOptDescr DarcsFlag)
optionMap [DarcsOptDescr DarcsFlag]
opts
    cmd_defs :: [(String, String)]
cmd_defs = CmdName -> [String] -> [(String, String)]
parseDefaultsLines CmdName
cmd [String]
def_lines
    all_defs :: [(String, String)]
all_defs = CmdName -> [String] -> [(String, String)]
parseDefaultsLines (String -> CmdName
NormalCmd String
"ALL") [String]
def_lines
    to_flag :: t String
-> (String, String) -> WriterT [String] Identity (Maybe DarcsFlag)
to_flag t String
all_switches (String
switch,String
arg) =
      if String
switch String -> t String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t String
all_switches then do
        [String] -> WriterT [String] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": command '"String -> String -> String
forall a. [a] -> [a] -> [a]
++CmdName -> String
showCmdName CmdName
cmd
             String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' has no option '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
switchString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'."]
        Maybe DarcsFlag -> WriterT [String] Identity (Maybe DarcsFlag)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DarcsFlag
forall a. Maybe a
Nothing
      else
        ([String] -> [String])
-> WriterT [String] Identity (Maybe DarcsFlag)
-> WriterT [String] Identity (Maybe DarcsFlag)
forall (t :: * -> *) a a b.
Foldable t =>
(t a -> [a]) -> Writer (t a) b -> Writer [a] b
mapErrors ((String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" for command '"String -> String -> String
forall a. [a] -> [a] -> [a]
++CmdName -> String
showCmdName CmdName
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"':")String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
          (WriterT [String] Identity (Maybe DarcsFlag)
 -> WriterT [String] Identity (Maybe DarcsFlag))
-> WriterT [String] Identity (Maybe DarcsFlag)
-> WriterT [String] Identity (Maybe DarcsFlag)
forall a b. (a -> b) -> a -> b
$ AbsolutePath
-> Map String (DarcsOptDescr DarcsFlag)
-> (String, String)
-> WriterT [String] Identity (Maybe DarcsFlag)
defaultToFlag AbsolutePath
cwd Map String (DarcsOptDescr DarcsFlag)
opt_map (String
switch,String
arg)
    -- the catMaybes filters out options that are not defined
    -- for this command
    flags_for :: t String -> [(String, String)] -> Writer [String] [DarcsFlag]
flags_for t String
all_switches = ([Maybe DarcsFlag] -> [DarcsFlag])
-> WriterT [String] Identity [Maybe DarcsFlag]
-> Writer [String] [DarcsFlag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe DarcsFlag] -> [DarcsFlag]
forall a. [Maybe a] -> [a]
catMaybes (WriterT [String] Identity [Maybe DarcsFlag]
 -> Writer [String] [DarcsFlag])
-> ([(String, String)]
    -> WriterT [String] Identity [Maybe DarcsFlag])
-> [(String, String)]
-> Writer [String] [DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> WriterT [String] Identity (Maybe DarcsFlag))
-> [(String, String)]
-> WriterT [String] Identity [Maybe DarcsFlag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (t String
-> (String, String) -> WriterT [String] Identity (Maybe DarcsFlag)
forall (t :: * -> *).
Foldable t =>
t String
-> (String, String) -> WriterT [String] Identity (Maybe DarcsFlag)
to_flag t String
all_switches)
    mapErrors :: (t a -> [a]) -> Writer (t a) b -> Writer [a] b
mapErrors t a -> [a]
f = ((b, t a) -> (b, [a])) -> Writer (t a) b -> Writer [a] b
forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(b
r, t a
es) -> (b
r, if t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
es then [] else t a -> [a]
f t a
es))

-- | Result of parsing a defaults line: switch and argument(s).
type Default = (String, String)

-- | Extract 'Default's from lines of a defaults file that match the given 'CmdName'.
-- 
-- The syntax is
--
-- @
--  supercmd subcmd [--]switch [args...]
-- @
--
-- for (super) commands with a sub command, and
--
-- @
--  cmd default [--]default [args...]
-- @
--
-- for normal commands (including the @ALL@ pseudo command).
parseDefaultsLines :: CmdName -> [String] -> [Default]
parseDefaultsLines :: CmdName -> [String] -> [(String, String)]
parseDefaultsLines CmdName
cmd = [Maybe (String, String)] -> [(String, String)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (String, String)] -> [(String, String)])
-> ([String] -> [Maybe (String, String)])
-> [String]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe (String, String))
-> [String] -> [Maybe (String, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe (String, String)
matchLine
  where
    matchLine :: String -> Maybe (String, String)
matchLine = RE Char (String, String) -> String -> Maybe (String, String)
forall s a. RE s a -> [s] -> Maybe a
match (RE Char (String, String) -> String -> Maybe (String, String))
-> RE Char (String, String) -> String -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (,) (String -> String -> (String, String))
-> RE Char String -> RE Char (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CmdName -> RE Char String
match_cmd CmdName
cmd RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
spaces RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
opt_dashes RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
word) RE Char (String -> (String, String))
-> RE Char String -> RE Char (String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE Char String
rest
    match_cmd :: CmdName -> RE Char String
match_cmd (NormalCmd String
name) = String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
name
    match_cmd (SuperCmd String
super String
sub) = String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
super RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
spaces RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
sub
    opt_dashes :: RE Char String
opt_dashes = String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
"--" RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> RE Char String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
    word :: RE Char String
word = RE Char Char -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (RE Char Char -> RE Char String) -> RE Char Char -> RE Char String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> RE Char Char
forall s. (s -> Bool) -> RE s s
psym (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace)
    spaces :: RE Char String
spaces = RE Char Char -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (RE Char Char -> RE Char String) -> RE Char Char -> RE Char String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> RE Char Char
forall s. (s -> Bool) -> RE s s
psym Char -> Bool
isSpace
    rest :: RE Char String
rest = RE Char String
spaces RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char Char -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many RE Char Char
forall s. RE s s
anySym RE Char String -> RE Char String -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> RE Char String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""

{- $note
This definition is a bit simpler, and doesn't need Text.Regex.Applicative,
but it has two disadvantages over the one above:

 * Flag arguments are split and joined again with words/unwords, which means
   that whitespace inside an argument is not preserved literally.

 * It is less easily extendable with new syntax.

> parseDefaultsLines :: CmdName -> [String] -> [(String, String)]
> parseDefaultsLines name entries = case name of
>     SuperCmd super sub -> [ mk_def d as | (s:c:d:as) <- map words entries, s == super, c == sub ]
>     NormalCmd cmd ->      [ mk_def d as | (c:d:as) <- map words entries, c == cmd ]
>   where
>     mk_def d as = (drop_dashes d, unwords as)
>     drop_dashes ('-':'-':switch) = switch
>     drop_dashes switch = switch
-}

-- | Search an option list for a switch. If found, apply the flag constructor
-- from the option to the arg, if any. The first parameter is the current working
-- directory, which, depending on the option type, may be needed to create a flag
-- from an argument.
-- 
-- Fails if (default has argument /= corresponding option has argument).
defaultToFlag :: AbsolutePath
              -> OptionMap
              -> Default
              -> Writer [String] (Maybe DarcsFlag)
defaultToFlag :: AbsolutePath
-> Map String (DarcsOptDescr DarcsFlag)
-> (String, String)
-> WriterT [String] Identity (Maybe DarcsFlag)
defaultToFlag AbsolutePath
cwd Map String (DarcsOptDescr DarcsFlag)
opts (String
switch, String
arg) = case String
-> Map String (DarcsOptDescr DarcsFlag)
-> Maybe (DarcsOptDescr DarcsFlag)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
switch Map String (DarcsOptDescr DarcsFlag)
opts of
    -- This case is not impossible! A default flag defined for ALL commands
    -- is not necessarily defined for the concrete command in question.
    Maybe (DarcsOptDescr DarcsFlag)
Nothing -> Maybe DarcsFlag -> WriterT [String] Identity (Maybe DarcsFlag)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DarcsFlag
forall a. Maybe a
Nothing
    Just DarcsOptDescr DarcsFlag
opt -> ArgDescr (AbsolutePath -> DarcsFlag)
-> WriterT [String] Identity (Maybe DarcsFlag)
forall (m :: * -> *) a.
MonadWriter [String] m =>
ArgDescr (AbsolutePath -> a) -> m (Maybe a)
flag_from (ArgDescr (AbsolutePath -> DarcsFlag)
 -> WriterT [String] Identity (Maybe DarcsFlag))
-> ArgDescr (AbsolutePath -> DarcsFlag)
-> WriterT [String] Identity (Maybe DarcsFlag)
forall a b. (a -> b) -> a -> b
$ OptDescr (AbsolutePath -> DarcsFlag)
-> ArgDescr (AbsolutePath -> DarcsFlag)
forall a. OptDescr a -> ArgDescr a
getArgDescr (OptDescr (AbsolutePath -> DarcsFlag)
 -> ArgDescr (AbsolutePath -> DarcsFlag))
-> OptDescr (AbsolutePath -> DarcsFlag)
-> ArgDescr (AbsolutePath -> DarcsFlag)
forall a b. (a -> b) -> a -> b
$ DarcsOptDescr DarcsFlag -> OptDescr (AbsolutePath -> DarcsFlag)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose DarcsOptDescr DarcsFlag
opt
  where
    getArgDescr :: OptDescr a -> ArgDescr a
getArgDescr (Option String
_ [String]
_ ArgDescr a
a String
_) = ArgDescr a
a
    flag_from :: ArgDescr (AbsolutePath -> a) -> m (Maybe a)
flag_from (NoArg AbsolutePath -> a
mkFlag) = do
      if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
arg) then do
        [String] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
switchString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' takes no argument, but '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
argString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' argument given."]
        Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else
        Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> a
mkFlag AbsolutePath
cwd
    flag_from (OptArg Maybe String -> AbsolutePath -> a
mkFlag String
_) =
      Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Maybe String -> AbsolutePath -> a
mkFlag (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
arg then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
arg) AbsolutePath
cwd
    flag_from (ReqArg String -> AbsolutePath -> a
mkFlag String
_) = do
      if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
arg then do
        [String] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
switchString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' requires an argument, but no "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"argument given."]
        Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else
        Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ String -> AbsolutePath -> a
mkFlag String
arg AbsolutePath
cwd

-- | Get all the longSwitches from a list of options.
optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]
optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]
optionSwitches = (DarcsOptDescr DarcsFlag -> [String])
-> [DarcsOptDescr DarcsFlag] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DarcsOptDescr DarcsFlag -> [String]
forall (g :: * -> *) a. Compose OptDescr g a -> [String]
sel where
  sel :: Compose OptDescr g a -> [String]
sel (Compose (Option String
_ [String]
switches ArgDescr (g a)
_ String
_)) = [String]
switches

-- | A finite map from long switches to 'DarcsOptDescr's.
type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)

-- | Build an 'OptionMap' from a list of 'DarcsOption's.
optionMap :: [DarcsOptDescr DarcsFlag] -> OptionMap
optionMap :: [DarcsOptDescr DarcsFlag] -> Map String (DarcsOptDescr DarcsFlag)
optionMap = [(String, DarcsOptDescr DarcsFlag)]
-> Map String (DarcsOptDescr DarcsFlag)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, DarcsOptDescr DarcsFlag)]
 -> Map String (DarcsOptDescr DarcsFlag))
-> ([DarcsOptDescr DarcsFlag]
    -> [(String, DarcsOptDescr DarcsFlag)])
-> [DarcsOptDescr DarcsFlag]
-> Map String (DarcsOptDescr DarcsFlag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DarcsOptDescr DarcsFlag -> [(String, DarcsOptDescr DarcsFlag)])
-> [DarcsOptDescr DarcsFlag] -> [(String, DarcsOptDescr DarcsFlag)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DarcsOptDescr DarcsFlag -> [(String, DarcsOptDescr DarcsFlag)]
forall (g :: * -> *) a.
Compose OptDescr g a -> [(String, Compose OptDescr g a)]
sel where
  add_option :: b -> a -> (a, b)
add_option b
opt a
switch = (a
switch, b
opt)
  sel :: Compose OptDescr g a -> [(String, Compose OptDescr g a)]
sel o :: Compose OptDescr g a
o@(Compose (Option String
_ [String]
switches ArgDescr (g a)
_ String
_)) = (String -> (String, Compose OptDescr g a))
-> [String] -> [(String, Compose OptDescr g a)]
forall a b. (a -> b) -> [a] -> [b]
map (Compose OptDescr g a -> String -> (String, Compose OptDescr g a)
forall b a. b -> a -> (a, b)
add_option Compose OptDescr g a
o) [String]
switches

-- | List of option switches of all commands (except help but that has no options).
allOptionSwitches :: [String]
allOptionSwitches :: [String]
allOptionSwitches = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [DarcsOptDescr DarcsFlag] -> [String]
optionSwitches ([DarcsOptDescr DarcsFlag] -> [String])
-> [DarcsOptDescr DarcsFlag] -> [String]
forall a b. (a -> b) -> a -> b
$
  (DarcsCommand -> [DarcsOptDescr DarcsFlag])
-> [DarcsCommand] -> [DarcsOptDescr DarcsFlag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([DarcsOptDescr DarcsFlag]
 -> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag])
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
-> [DarcsOptDescr DarcsFlag]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
(++) (([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
 -> [DarcsOptDescr DarcsFlag])
-> (DarcsCommand
    -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag]))
-> DarcsCommand
-> [DarcsOptDescr DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions) ([DarcsCommand] -> [DarcsOptDescr DarcsFlag])
-> [DarcsCommand] -> [DarcsOptDescr DarcsFlag]
forall a b. (a -> b) -> a -> b
$
            [CommandControl] -> [DarcsCommand]
extractAllCommands [CommandControl]
commandControlList