module Darcs.UI.Defaults ( applyDefaults ) where

import Darcs.Prelude

import Control.Monad.Writer
import Data.Char ( isLetter, isSpace )
import Data.Either ( partitionEithers )
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, sym
    , psym, anySym, string )

import Darcs.UI.Flags ( DarcsFlag )
import Darcs.UI.Options ( DarcsOptDescr, OptMsg(..), withDashes )

import Darcs.UI.Commands
    ( DarcsCommand
    , commandAlloptions
    , commandCheckOptions
    , commandDefaults
    , commandName
    , 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], [String])) -- new flags, warnings, errors
applyDefaults :: Maybe String
-> DarcsCommand
-> AbsolutePath
-> [String]
-> [String]
-> [DarcsFlag]
-> ([DarcsFlag], ([String], [String]))
applyDefaults Maybe String
msuper DarcsCommand
cmd AbsolutePath
cwd [String]
user [String]
repo [DarcsFlag]
flags =
  ([DarcsFlag], [OptMsg]) -> ([DarcsFlag], ([String], [String]))
forall {a}. (a, [OptMsg]) -> (a, ([String], [String]))
splitMessages (([DarcsFlag], [OptMsg]) -> ([DarcsFlag], ([String], [String])))
-> ([DarcsFlag], [OptMsg]) -> ([DarcsFlag], ([String], [String]))
forall a b. (a -> b) -> a -> b
$ Writer [OptMsg] [DarcsFlag] -> ([DarcsFlag], [OptMsg])
forall w a. Writer w a -> (a, w)
runWriter (Writer [OptMsg] [DarcsFlag] -> ([DarcsFlag], [OptMsg]))
-> Writer [OptMsg] [DarcsFlag] -> ([DarcsFlag], [OptMsg])
forall a b. (a -> b) -> a -> b
$ do
    [DarcsFlag]
cl_flags  <- String
-> ([DarcsFlag] -> [OptMsg])
-> [DarcsFlag]
-> Writer [OptMsg] [DarcsFlag]
runChecks String
"Command line" [DarcsFlag] -> [OptMsg]
check_opts [DarcsFlag]
flags
    [DarcsFlag]
user_defs <- String -> [String] -> Writer [OptMsg] [DarcsFlag]
get_flags String
"User defaults" [String]
user
    [DarcsFlag]
repo_defs <- String -> [String] -> Writer [OptMsg] [DarcsFlag]
get_flags String
"Repo defaults" [String]
repo
    [DarcsFlag] -> Writer [OptMsg] [DarcsFlag]
forall a. a -> WriterT [OptMsg] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DarcsFlag] -> Writer [OptMsg] [DarcsFlag])
-> [DarcsFlag] -> Writer [OptMsg] [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] -> [OptMsg]
check_opts = DarcsCommand -> [DarcsFlag] -> [OptMsg]
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 [OptMsg] [DarcsFlag]
get_flags String
source = String
-> AbsolutePath
-> CmdName
-> [DarcsOptDescr DarcsFlag]
-> ([DarcsFlag] -> [OptMsg])
-> [String]
-> Writer [OptMsg] [DarcsFlag]
parseDefaults String
source AbsolutePath
cwd CmdName
cmd_name [DarcsOptDescr DarcsFlag]
opts [DarcsFlag] -> [OptMsg]
check_opts
    splitMessages :: (a, [OptMsg]) -> (a, ([String], [String]))
splitMessages (a
r,[OptMsg]
ms) = (a
r,[OptMsg] -> ([String], [String])
partitionOptMsgs [OptMsg]
ms)

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

mapOptMsg :: (String -> String) -> OptMsg -> OptMsg
mapOptMsg :: (String -> String) -> OptMsg -> OptMsg
mapOptMsg String -> String
f (OptWarning String
s) = String -> OptMsg
OptWarning (String -> String
f String
s)
mapOptMsg String -> String
f (OptError String
s) = String -> OptMsg
OptError (String -> String
f String
s)

partitionOptMsgs :: [OptMsg] -> ([String], [String])
partitionOptMsgs :: [OptMsg] -> ([String], [String])
partitionOptMsgs = [Either String String] -> ([String], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String String] -> ([String], [String]))
-> ([OptMsg] -> [Either String String])
-> [OptMsg]
-> ([String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptMsg -> Either String String)
-> [OptMsg] -> [Either String String]
forall a b. (a -> b) -> [a] -> [b]
map OptMsg -> Either String String
toEither where
  toEither :: OptMsg -> Either String String
toEither (OptWarning String
s) = String -> Either String String
forall a b. a -> Either a b
Left String
s
  toEither (OptError String
s) = String -> Either String String
forall a b. b -> Either a b
Right String
s

-- | 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] -> [OptMsg])
              -> [String]
              -> Writer [OptMsg] [DarcsFlag]
parseDefaults :: String
-> AbsolutePath
-> CmdName
-> [DarcsOptDescr DarcsFlag]
-> ([DarcsFlag] -> [OptMsg])
-> [String]
-> Writer [OptMsg] [DarcsFlag]
parseDefaults String
source AbsolutePath
cwd CmdName
cmd [DarcsOptDescr DarcsFlag]
opts [DarcsFlag] -> [OptMsg]
check_opts [String]
def_lines = do
    [DarcsFlag]
cmd_flags <- [String] -> [(String, String)] -> Writer [OptMsg] [DarcsFlag]
forall {t :: * -> *}.
Foldable t =>
t String -> [(String, String)] -> Writer [OptMsg] [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 [OptMsg] [DarcsFlag]
-> ([DarcsFlag] -> Writer [OptMsg] [DarcsFlag])
-> Writer [OptMsg] [DarcsFlag]
forall a b.
WriterT [OptMsg] Identity a
-> (a -> WriterT [OptMsg] Identity b)
-> WriterT [OptMsg] Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      String
-> ([DarcsFlag] -> [OptMsg])
-> [DarcsFlag]
-> Writer [OptMsg] [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] -> [OptMsg]
check_opts
    [DarcsFlag]
all_flags <- [String] -> [(String, String)] -> Writer [OptMsg] [DarcsFlag]
forall {t :: * -> *}.
Foldable t =>
t String -> [(String, String)] -> Writer [OptMsg] [DarcsFlag]
flags_for [String]
allOptionSwitches [(String, String)]
all_defs Writer [OptMsg] [DarcsFlag]
-> ([DarcsFlag] -> Writer [OptMsg] [DarcsFlag])
-> Writer [OptMsg] [DarcsFlag]
forall a b.
WriterT [OptMsg] Identity a
-> (a -> WriterT [OptMsg] Identity b)
-> WriterT [OptMsg] Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      String
-> ([DarcsFlag] -> [OptMsg])
-> [DarcsFlag]
-> Writer [OptMsg] [DarcsFlag]
runChecks (String
sourceString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" for ALL commands") [DarcsFlag] -> [OptMsg]
check_opts
    [DarcsFlag] -> Writer [OptMsg] [DarcsFlag]
forall a. a -> WriterT [OptMsg] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DarcsFlag] -> Writer [OptMsg] [DarcsFlag])
-> [DarcsFlag] -> Writer [OptMsg] [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 [OptMsg] 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
        [OptMsg] -> WriterT [OptMsg] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ String -> OptMsg
OptWarning (String -> OptMsg) -> String -> OptMsg
forall a b. (a -> b) -> a -> b
$ 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 [OptMsg] Identity (Maybe DarcsFlag)
forall a. a -> WriterT [OptMsg] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DarcsFlag
forall a. Maybe a
Nothing
      else
        ([OptMsg] -> [OptMsg])
-> WriterT [OptMsg] Identity (Maybe DarcsFlag)
-> WriterT [OptMsg] Identity (Maybe DarcsFlag)
forall {t :: * -> *} {a} {a} {b}.
Foldable t =>
(t a -> [a]) -> Writer (t a) b -> Writer [a] b
mapErrors ((String -> OptMsg
OptWarning (String -> OptMsg) -> String -> OptMsg
forall a b. (a -> b) -> a -> b
$ 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
"':")OptMsg -> [OptMsg] -> [OptMsg]
forall a. a -> [a] -> [a]
:)
          (WriterT [OptMsg] Identity (Maybe DarcsFlag)
 -> WriterT [OptMsg] Identity (Maybe DarcsFlag))
-> WriterT [OptMsg] Identity (Maybe DarcsFlag)
-> WriterT [OptMsg] Identity (Maybe DarcsFlag)
forall a b. (a -> b) -> a -> b
$ AbsolutePath
-> Map String (DarcsOptDescr DarcsFlag)
-> (String, String)
-> WriterT [OptMsg] 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 [OptMsg] [DarcsFlag]
flags_for t String
all_switches = ([Maybe DarcsFlag] -> [DarcsFlag])
-> WriterT [OptMsg] Identity [Maybe DarcsFlag]
-> Writer [OptMsg] [DarcsFlag]
forall a b.
(a -> b)
-> WriterT [OptMsg] Identity a -> WriterT [OptMsg] Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe DarcsFlag] -> [DarcsFlag]
forall a. [Maybe a] -> [a]
catMaybes (WriterT [OptMsg] Identity [Maybe DarcsFlag]
 -> Writer [OptMsg] [DarcsFlag])
-> ([(String, String)]
    -> WriterT [OptMsg] Identity [Maybe DarcsFlag])
-> [(String, String)]
-> Writer [OptMsg] [DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> WriterT [OptMsg] Identity (Maybe DarcsFlag))
-> [(String, String)]
-> WriterT [OptMsg] Identity [Maybe DarcsFlag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (t String
-> (String, String) -> WriterT [OptMsg] Identity (Maybe DarcsFlag)
forall {t :: * -> *}.
Foldable t =>
t String
-> (String, String) -> WriterT [OptMsg] 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 a. 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 a b. RE Char a -> RE Char b -> RE Char b
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 a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
option) RE Char (String -> (String, String))
-> RE Char String -> RE Char (String, String)
forall a b. RE Char (a -> b) -> RE Char a -> RE Char b
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 a b. RE Char a -> RE Char b -> RE Char b
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 a b. RE Char a -> RE Char b -> RE Char b
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
    option :: RE Char String
option = RE Char String
short RE Char String -> RE Char String -> RE Char String
forall a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RE Char String
long
    short :: RE Char String
short = (\Char
c1 Char
c2 -> [Char
c1,Char
c2]) (Char -> Char -> String)
-> RE Char Char -> RE Char (Char -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> RE Char Char
forall s. Eq s => s -> RE s s
sym Char
'-' RE Char (Char -> String) -> RE Char Char -> RE Char String
forall a b. RE Char (a -> b) -> RE Char a -> RE Char b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> RE Char Char
forall s. (s -> Bool) -> RE s s
psym Char -> Bool
isLetter
    long :: RE Char String
long = String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> RE Char String -> RE Char (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE Char String
opt_dashes RE Char (String -> String) -> RE Char String -> RE Char String
forall a b. RE Char (a -> b) -> RE Char a -> RE Char b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE Char String
word
    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 a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> RE Char String
forall a. a -> RE Char a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"--"
    word :: RE Char String
word = (:) (Char -> String -> String)
-> RE Char Char -> RE Char (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> RE Char Char
forall s. (s -> Bool) -> RE s s
psym Char -> Bool
isLetter RE Char (String -> String) -> RE Char String -> RE Char String
forall a b. RE Char (a -> b) -> RE Char a -> RE Char b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE Char Char -> RE Char String
forall a. RE Char a -> RE Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((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 a. RE Char a -> RE Char [a]
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 a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char Char -> RE Char String
forall a. RE Char a -> RE Char [a]
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 a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> RE Char String
forall a. a -> RE Char a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""

-- | 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 [OptMsg] (Maybe DarcsFlag)
defaultToFlag :: AbsolutePath
-> Map String (DarcsOptDescr DarcsFlag)
-> (String, String)
-> WriterT [OptMsg] 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 [OptMsg] Identity (Maybe DarcsFlag)
forall a. a -> WriterT [OptMsg] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DarcsFlag
forall a. Maybe a
Nothing
    Just DarcsOptDescr DarcsFlag
opt -> ArgDescr (AbsolutePath -> DarcsFlag)
-> WriterT [OptMsg] Identity (Maybe DarcsFlag)
forall {m :: * -> *} {a}.
MonadWriter [OptMsg] m =>
ArgDescr (AbsolutePath -> a) -> m (Maybe a)
flag_from (ArgDescr (AbsolutePath -> DarcsFlag)
 -> WriterT [OptMsg] Identity (Maybe DarcsFlag))
-> ArgDescr (AbsolutePath -> DarcsFlag)
-> WriterT [OptMsg] 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} {k2} (f :: k1 -> *) (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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
arg) then do
        [OptMsg] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
          [ String -> OptMsg
OptWarning (String -> OptMsg) -> String -> OptMsg
forall a b. (a -> b) -> a -> b
$
            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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else
        Maybe a -> m (Maybe a)
forall a. a -> m 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 a. a -> m 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 a. [a] -> 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
arg then do
        [OptMsg] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
          [ String -> OptMsg
OptError (String -> OptMsg) -> String -> OptMsg
forall a b. (a -> b) -> a -> b
$
            String
"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
switchString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' requires an argument, but no argument given." ]
        Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else
        Maybe a -> m (Maybe a)
forall a. a -> m 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 flag names from an options
optionSwitches :: DarcsOptDescr DarcsFlag -> [String]
optionSwitches :: DarcsOptDescr DarcsFlag -> [String]
optionSwitches (Compose (Option String
short [String]
long ArgDescr (AbsolutePath -> DarcsFlag)
_ String
_)) = String -> [String] -> [String]
withDashes String
short [String]
long

-- | A finite map from flag names 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)]
sel where
  add_option :: b -> a -> (a, b)
add_option b
opt a
switch = (a
switch, b
opt)
  sel :: DarcsOptDescr DarcsFlag -> [(String, DarcsOptDescr DarcsFlag)]
sel DarcsOptDescr DarcsFlag
o = (String -> (String, DarcsOptDescr DarcsFlag))
-> [String] -> [(String, DarcsOptDescr DarcsFlag)]
forall a b. (a -> b) -> [a] -> [b]
map (DarcsOptDescr DarcsFlag
-> String -> (String, DarcsOptDescr DarcsFlag)
forall {b} {a}. b -> a -> (a, b)
add_option DarcsOptDescr DarcsFlag
o) (DarcsOptDescr DarcsFlag -> [String]
optionSwitches DarcsOptDescr DarcsFlag
o)

-- | 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])
-> [DarcsOptDescr DarcsFlag] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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