{-# LANGUAGE Rank2Types #-}
module Options.Applicative.Common (
  -- * Option parsers
  --
  -- | A 'Parser' is composed of a list of options. Several kinds of options
  -- are supported:
  --
  --  * Flags: simple no-argument options. When a flag is encountered on the
  --  command line, its value is returned.
  --
  --  * Options: options with an argument. An option can define a /reader/,
  --  which converts its argument from String to the desired value, or throws a
  --  parse error if the argument does not validate correctly.
  --
  --  * Arguments: positional arguments, validated in the same way as option
  --  arguments.
  --
  --  * Commands. A command defines a completely independent sub-parser. When a
  --  command is encountered, the whole command line is passed to the
  --  corresponding parser.
  --
  Parser,
  liftOpt,
  showOption,

  -- * Program descriptions
  --
  -- A 'ParserInfo' describes a command line program, used to generate a help
  -- screen. Two help modes are supported: brief and full. In brief mode, only
  -- an option and argument summary is displayed, while in full mode each
  -- available option and command, including hidden ones, is described.
  --
  -- A basic 'ParserInfo' with default values for fields can be created using
  -- the 'info' function.
  --
  -- A 'ParserPrefs' contains general preferences for all command-line
  -- options, and can be built with the 'prefs' function.
  ParserInfo(..),
  ParserPrefs(..),

  -- * Running parsers
  runParserInfo,
  runParserFully,
  runParserStep,
  runParser,
  evalParser,

  -- * Low-level utilities
  mapParser,
  treeMapParser,
  optionNames
  ) where

import Control.Applicative
import Control.Monad (guard, mzero, msum, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
import Data.List (isPrefixOf)
import Data.Maybe (maybeToList, isJust, isNothing)
import Prelude

import Options.Applicative.Internal
import Options.Applicative.Types

showOption :: OptName -> String
showOption :: OptName -> String
showOption (OptLong String
n) = String
"--" forall a. [a] -> [a] -> [a]
++ String
n
showOption (OptShort Char
n) = Char
'-' forall a. a -> [a] -> [a]
: [Char
n]

optionNames :: OptReader a -> [OptName]
optionNames :: forall a. OptReader a -> [OptName]
optionNames (OptReader [OptName]
names CReader a
_ String -> ParseError
_) = [OptName]
names
optionNames (FlagReader [OptName]
names a
_) = [OptName]
names
optionNames OptReader a
_ = []

isOptionPrefix :: OptName -> OptName -> Bool
isOptionPrefix :: OptName -> OptName -> Bool
isOptionPrefix (OptShort Char
x) (OptShort Char
y) = Char
x forall a. Eq a => a -> a -> Bool
== Char
y
isOptionPrefix (OptLong String
x) (OptLong String
y) = String
x forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
y
isOptionPrefix OptName
_ OptName
_ = Bool
False

-- | Create a parser composed of a single option.
liftOpt :: Option a -> Parser a
liftOpt :: forall a. Option a -> Parser a
liftOpt = forall a. Option a -> Parser a
OptP

optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
optMatches :: forall (m :: * -> *) a.
MonadP m =>
Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
optMatches Bool
disambiguate OptReader a
opt (OptWord OptName
arg1 Maybe String
val) = case OptReader a
opt of
  OptReader [OptName]
names CReader a
rdr String -> ParseError
no_arg_err -> do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}. Foldable t => OptName -> t OptName -> Bool
has_name OptName
arg1 [OptName]
names
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      Args
args <- forall (m :: * -> *) s. Monad m => StateT s m s
get
      let mb_args :: Maybe (String, Args)
mb_args = forall a. [a] -> Maybe (a, [a])
uncons forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe String
val forall a. [a] -> [a] -> [a]
++ Args
args
      let missing_arg :: m a
missing_arg = forall (m :: * -> *) a. MonadP m => ParseError -> Completer -> m a
missingArgP (String -> ParseError
no_arg_err forall a b. (a -> b) -> a -> b
$ OptName -> String
showOption OptName
arg1) (forall a. CReader a -> Completer
crCompleter CReader a
rdr)
      (String
arg', Args
args') <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall {a}. m a
missing_arg) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, Args)
mb_args
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Args
args'
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadP m => ReadM a -> String -> m a
runReadM (forall a. (String -> String) -> ReadM a -> ReadM a
withReadM (OptName -> String -> String
errorFor OptName
arg1) (forall a. CReader a -> ReadM a
crReader CReader a
rdr)) String
arg'

  FlagReader [OptName]
names a
x -> do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}. Foldable t => OptName -> t OptName -> Bool
has_name OptName
arg1 [OptName]
names
    -- #242 Flags/switches succeed incorrectly when given an argument.
    -- We'll not match a long option for a flag if there's a word attached.
    -- This was revealing an implementation detail as
    -- `--foo=val` was being parsed as `--foo -val`, which is gibberish.
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ OptName -> Bool
isShortName OptName
arg1 Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing Maybe String
val
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      Args
args <- forall (m :: * -> *) s. Monad m => StateT s m s
get
      let val' :: Maybe String
val' = (Char
'-' forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
val
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe String
val' forall a. [a] -> [a] -> [a]
++ Args
args
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  OptReader a
_ -> forall a. Maybe a
Nothing
  where
    errorFor :: OptName -> String -> String
errorFor OptName
name String
msg = String
"option " forall a. [a] -> [a] -> [a]
++ OptName -> String
showOption OptName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg

    has_name :: OptName -> t OptName -> Bool
has_name OptName
a
      | Bool
disambiguate = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (OptName -> OptName -> Bool
isOptionPrefix OptName
a)
      | Bool
otherwise = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem OptName
a

isArg :: OptReader a -> Bool
isArg :: forall a. OptReader a -> Bool
isArg (ArgReader CReader a
_) = Bool
True
isArg OptReader a
_ = Bool
False

data OptWord = OptWord OptName (Maybe String)

parseWord :: String -> Maybe OptWord
parseWord :: String -> Maybe OptWord
parseWord (Char
'-' : Char
'-' : String
w) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ let
  (String
opt, Maybe String
arg) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'=') String
w of
    (String
_, String
"") -> (String
w, forall a. Maybe a
Nothing)
    (String
w', Char
_ : String
rest) -> (String
w', forall a. a -> Maybe a
Just String
rest)
  in OptName -> Maybe String -> OptWord
OptWord (String -> OptName
OptLong String
opt) Maybe String
arg
parseWord (Char
'-' : String
w) = case String
w of
  [] -> forall a. Maybe a
Nothing
  (Char
a : String
rest) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ let
    arg :: Maybe String
arg = String
rest forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest))
    in OptName -> Maybe String -> OptWord
OptWord (Char -> OptName
OptShort Char
a) Maybe String
arg
parseWord String
_ = forall a. Maybe a
Nothing

searchParser :: Monad m
             => (forall r . Option r -> NondetT m (Parser r))
             -> Parser a -> NondetT m (Parser a)
searchParser :: forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
_ (NilP Maybe a
_) = forall (m :: * -> *) a. MonadPlus m => m a
mzero
searchParser forall r. Option r -> NondetT m (Parser r)
f (OptP Option a
opt) = forall r. Option r -> NondetT m (Parser r)
f Option a
opt
searchParser forall r. Option r -> NondetT m (Parser r)
f (MultP Parser (x -> a)
p1 Parser x
p2) = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (m :: * -> *) a.
Monad m =>
NondetT m a -> NondetT m a -> NondetT m a
(<!>)
  [ do Parser (x -> a)
p1' <- forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f Parser (x -> a)
p1
       forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser x
p2)
  , do Parser x
p2' <- forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f Parser x
p2
       forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser x
p2') ]
searchParser forall r. Option r -> NondetT m (Parser r)
f (AltP Parser a
p1 Parser a
p2) = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f Parser a
p1
  , forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f Parser a
p2 ]
searchParser forall r. Option r -> NondetT m (Parser r)
f (BindP Parser x
p x -> Parser a
k) = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ do Parser x
p' <- forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f Parser x
p
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a x. Parser x -> (x -> Parser a) -> Parser a
BindP Parser x
p' x -> Parser a
k
  , case forall a. Parser a -> Maybe a
evalParser Parser x
p of
      Maybe x
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
      Just x
aa -> forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall r. Option r -> NondetT m (Parser r)
f (x -> Parser a
k x
aa) ]

searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a
          -> NondetT (StateT Args m) (Parser a)
searchOpt :: forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
searchOpt ParserPrefs
pprefs OptWord
w = forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall a b. (a -> b) -> a -> b
$ \Option r
opt -> do
  let disambiguate :: Bool
disambiguate = ParserPrefs -> Bool
prefDisambiguate ParserPrefs
pprefs
                  Bool -> Bool -> Bool
&& forall a. Option a -> OptVisibility
optVisibility Option r
opt forall a. Ord a => a -> a -> Bool
> OptVisibility
Internal
  case forall (m :: * -> *) a.
MonadP m =>
Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
optMatches Bool
disambiguate (forall a. Option a -> OptReader a
optMain Option r
opt) OptWord
w of
    Just StateT Args m r
matcher -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT Args m r
matcher
    Maybe (StateT Args m r)
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero

searchArg :: MonadP m => ParserPrefs -> String -> Parser a
          -> NondetT (StateT Args m) (Parser a)
searchArg :: forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg ParserPrefs
prefs String
arg =
  forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser forall a b. (a -> b) -> a -> b
$ \Option r
opt -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. OptReader a -> Bool
isArg (forall a. Option a -> OptReader a
optMain Option r
opt)) forall (m :: * -> *). Monad m => NondetT m ()
cut
    case forall a. Option a -> OptReader a
optMain Option r
opt of
      CmdReader Maybe String
_ [(String, ParserInfo r)]
cs -> do
        ParserInfo r
subp <- forall (m :: * -> *) a. Alternative m => [a] -> m a
hoistList (forall {b}. [(String, b)] -> [b]
cmdMatches [(String, ParserInfo r)]
cs)
        case ParserPrefs -> Backtracking
prefBacktrack ParserPrefs
prefs of
          Backtracking
NoBacktrack -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
            Args
args <- forall (m :: * -> *) s. Monad m => StateT s m s
get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put []
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadP m => ParserInfo a -> Args -> m a
runParserInfo ParserInfo r
subp Args
args forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). MonadP m => m ()
exitContext

          Backtracking
Backtrack -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \Args
args ->
            forall (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser (forall a. ParserInfo a -> ArgPolicy
infoPolicy ParserInfo r
subp) IsCmdStart
CmdStart (forall a. ParserInfo a -> Parser a
infoParser ParserInfo r
subp) Args
args forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). MonadP m => m ()
exitContext

          Backtracking
SubparserInline -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ParserInfo a -> Parser a
infoParser ParserInfo r
subp

      ArgReader CReader r
rdr ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadP m => ReadM a -> String -> m a
runReadM (forall a. CReader a -> ReadM a
crReader CReader r
rdr) String
arg
      OptReader r
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero

  where
    cmdMatches :: [(String, b)] -> [b]
cmdMatches [(String, b)]
cs
      | ParserPrefs -> Bool
prefDisambiguate ParserPrefs
prefs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
arg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, b)]
cs
      | Bool
otherwise = forall a. Maybe a -> [a]
maybeToList (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
arg [(String, b)]
cs)

stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
           -> Parser a -> NondetT (StateT Args m) (Parser a)
stepParser :: forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> ArgPolicy
-> String
-> Parser a
-> NondetT (StateT Args m) (Parser a)
stepParser ParserPrefs
pprefs ArgPolicy
AllPositionals String
arg Parser a
p =
  forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg ParserPrefs
pprefs String
arg Parser a
p
stepParser ParserPrefs
pprefs ArgPolicy
ForwardOptions String
arg Parser a
p = case String -> Maybe OptWord
parseWord String
arg of
  Just OptWord
w -> forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
searchOpt ParserPrefs
pprefs OptWord
w Parser a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg ParserPrefs
pprefs String
arg Parser a
p
  Maybe OptWord
Nothing -> forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg ParserPrefs
pprefs String
arg Parser a
p
stepParser ParserPrefs
pprefs ArgPolicy
_ String
arg Parser a
p = case String -> Maybe OptWord
parseWord String
arg of
  Just OptWord
w -> forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
searchOpt ParserPrefs
pprefs OptWord
w Parser a
p
  Maybe OptWord
Nothing -> forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg ParserPrefs
pprefs String
arg Parser a
p


-- | Apply a 'Parser' to a command line, and return a result and leftover
-- arguments.  This function returns an error if any parsing error occurs, or
-- if any options are missing and don't have a default value.
runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser :: forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser ArgPolicy
policy IsCmdStart
_ Parser a
p (String
"--" : Args
argt) | ArgPolicy
policy forall a. Eq a => a -> a -> Bool
/= ArgPolicy
AllPositionals
                                   = forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser ArgPolicy
AllPositionals IsCmdStart
CmdCont Parser a
p Args
argt
runParser ArgPolicy
policy IsCmdStart
isCmdStart Parser a
p Args
args = case Args
args of
  [] -> forall (m :: * -> *) b a.
MonadP m =>
IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a
exitP IsCmdStart
isCmdStart ArgPolicy
policy Parser a
p Maybe (a, Args)
result
  (String
arg : Args
argt) -> do
    (Maybe (Parser a)
mp', Args
args') <- String -> Args -> m (Maybe (Parser a), Args)
do_step String
arg Args
argt
    case Maybe (Parser a)
mp' of
      Maybe (Parser a)
Nothing -> forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
hoistMaybe Maybe (a, Args)
result forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
arg Parser a
p
      Just Parser a
p' -> forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser (String -> ArgPolicy
newPolicy String
arg) IsCmdStart
CmdCont Parser a
p' Args
args'
  where
    result :: Maybe (a, Args)
result =
      (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Maybe a
evalParser Parser a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Args
args
    do_step :: String -> Args -> m (Maybe (Parser a), Args)
do_step =
      forall (m :: * -> *) a.
MonadP m =>
ArgPolicy
-> Parser a -> String -> Args -> m (Maybe (Parser a), Args)
runParserStep ArgPolicy
policy Parser a
p

    newPolicy :: String -> ArgPolicy
newPolicy String
a = case ArgPolicy
policy of
      ArgPolicy
NoIntersperse -> if forall a. Maybe a -> Bool
isJust (String -> Maybe OptWord
parseWord String
a) then ArgPolicy
NoIntersperse else ArgPolicy
AllPositionals
      ArgPolicy
x             -> ArgPolicy
x

runParserStep :: MonadP m => ArgPolicy -> Parser a -> String -> Args -> m (Maybe (Parser a), Args)
runParserStep :: forall (m :: * -> *) a.
MonadP m =>
ArgPolicy
-> Parser a -> String -> Args -> m (Maybe (Parser a), Args)
runParserStep ArgPolicy
policy Parser a
p String
arg Args
args = do
  ParserPrefs
prefs <- forall (m :: * -> *). MonadP m => m ParserPrefs
getPrefs
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Args
args
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
Bool -> NondetT m a -> m (Maybe a)
disamb (Bool -> Bool
not (ParserPrefs -> Bool
prefDisambiguate ParserPrefs
prefs))
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> ArgPolicy
-> String
-> Parser a
-> NondetT (StateT Args m) (Parser a)
stepParser ParserPrefs
prefs ArgPolicy
policy String
arg Parser a
p

parseError :: MonadP m => String -> Parser x -> m a
parseError :: forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
arg = forall (m :: * -> *) a. MonadP m => ParseError -> m a
errorP forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SomeParser -> ParseError
UnexpectedError String
arg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> SomeParser
SomeParser

runParserInfo :: MonadP m => ParserInfo a -> Args -> m a
runParserInfo :: forall (m :: * -> *) a. MonadP m => ParserInfo a -> Args -> m a
runParserInfo ParserInfo a
i = forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> Parser a -> Args -> m a
runParserFully (forall a. ParserInfo a -> ArgPolicy
infoPolicy ParserInfo a
i) (forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i)

runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a
runParserFully :: forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> Parser a -> Args -> m a
runParserFully ArgPolicy
policy Parser a
p Args
args = do
  (a
r, Args
args') <- forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser ArgPolicy
policy IsCmdStart
CmdStart Parser a
p Args
args
  case Args
args' of
    []  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
r
    String
a:Args
_ -> forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
a (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | The default value of a 'Parser'.  This function returns an error if any of
-- the options don't have a default value.
evalParser :: Parser a -> Maybe a
evalParser :: forall a. Parser a -> Maybe a
evalParser (NilP Maybe a
r) = Maybe a
r
evalParser (OptP Option a
_) = forall a. Maybe a
Nothing
evalParser (MultP Parser (x -> a)
p1 Parser x
p2) = forall a. Parser a -> Maybe a
evalParser Parser (x -> a)
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser a -> Maybe a
evalParser Parser x
p2
evalParser (AltP Parser a
p1 Parser a
p2) = forall a. Parser a -> Maybe a
evalParser Parser a
p1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Maybe a
evalParser Parser a
p2
evalParser (BindP Parser x
p x -> Parser a
k) = forall a. Parser a -> Maybe a
evalParser Parser x
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Parser a -> Maybe a
evalParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Parser a
k

-- | Map a polymorphic function over all the options of a parser, and collect
-- the results in a list.
mapParser :: (forall x. ArgumentReachability -> Option x -> b)
          -> Parser a -> [b]
mapParser :: forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser forall x. ArgumentReachability -> Option x -> b
f = forall {a}. OptTree a -> [a]
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
treeMapParser forall x. ArgumentReachability -> Option x -> b
f
  where
    flatten :: OptTree a -> [a]
flatten (Leaf a
x) = [a
x]
    flatten (MultNode [OptTree a]
xs) = [OptTree a]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OptTree a -> [a]
flatten
    flatten (AltNode AltNodeType
_ [OptTree a]
xs) = [OptTree a]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OptTree a -> [a]
flatten
    flatten (BindNode OptTree a
x) = OptTree a -> [a]
flatten OptTree a
x

-- | Like 'mapParser', but collect the results in a tree structure.
treeMapParser :: (forall x. ArgumentReachability -> Option x -> b)
          -> Parser a
          -> OptTree b
treeMapParser :: forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
treeMapParser forall x. ArgumentReachability -> Option x -> b
g = forall a. OptTree a -> OptTree a
simplify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
False forall x. ArgumentReachability -> Option x -> b
g
  where
    has_default :: Parser a -> Bool
    has_default :: forall a. Parser a -> Bool
has_default Parser a
p = forall a. Maybe a -> Bool
isJust (forall a. Parser a -> Maybe a
evalParser Parser a
p)

    go :: Bool
       -> (forall x. ArgumentReachability -> Option x -> b)
       -> Parser a
       -> OptTree b
    go :: forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
_ forall x. ArgumentReachability -> Option x -> b
_ (NilP Maybe a
_) = forall a. [OptTree a] -> OptTree a
MultNode []
    go Bool
r forall x. ArgumentReachability -> Option x -> b
f (OptP Option a
opt)
      | forall a. Option a -> OptVisibility
optVisibility Option a
opt forall a. Ord a => a -> a -> Bool
> OptVisibility
Internal
      = forall a. a -> OptTree a
Leaf (forall x. ArgumentReachability -> Option x -> b
f (Bool -> ArgumentReachability
ArgumentReachability Bool
r) Option a
opt)
      | Bool
otherwise
      = forall a. [OptTree a] -> OptTree a
MultNode []
    go Bool
r forall x. ArgumentReachability -> Option x -> b
f (MultP Parser (x -> a)
p1 Parser x
p2) =
      forall a. [OptTree a] -> OptTree a
MultNode [forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r forall x. ArgumentReachability -> Option x -> b
f Parser (x -> a)
p1, forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r' forall x. ArgumentReachability -> Option x -> b
f Parser x
p2]
      where r' :: Bool
r' = Bool
r Bool -> Bool -> Bool
|| forall a. Parser a -> Bool
hasArg Parser (x -> a)
p1
    go Bool
r forall x. ArgumentReachability -> Option x -> b
f (AltP Parser a
p1 Parser a
p2) =
      forall a. AltNodeType -> [OptTree a] -> OptTree a
AltNode AltNodeType
altNodeType [forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r forall x. ArgumentReachability -> Option x -> b
f Parser a
p1, forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r forall x. ArgumentReachability -> Option x -> b
f Parser a
p2]
      where
        -- The 'AltNode' indicates if one of the branches has a default.
        -- This is used for rendering brackets, as well as filtering
        -- out optional arguments when generating the "missing:" text.
        altNodeType :: AltNodeType
altNodeType =
          if forall a. Parser a -> Bool
has_default Parser a
p1 Bool -> Bool -> Bool
|| forall a. Parser a -> Bool
has_default Parser a
p2
            then AltNodeType
MarkDefault
            else AltNodeType
NoDefault

    go Bool
r forall x. ArgumentReachability -> Option x -> b
f (BindP Parser x
p x -> Parser a
k) =
      let go' :: OptTree b
go' = forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r forall x. ArgumentReachability -> Option x -> b
f Parser x
p
      in case forall a. Parser a -> Maybe a
evalParser Parser x
p of
        Maybe x
Nothing -> forall a. OptTree a -> OptTree a
BindNode OptTree b
go'
        Just x
aa -> forall a. OptTree a -> OptTree a
BindNode (forall a. [OptTree a] -> OptTree a
MultNode [ OptTree b
go', forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r forall x. ArgumentReachability -> Option x -> b
f (x -> Parser a
k x
aa) ])

    hasArg :: Parser a -> Bool
    hasArg :: forall a. Parser a -> Bool
hasArg (NilP Maybe a
_) = Bool
False
    hasArg (OptP Option a
p) = (forall a. OptReader a -> Bool
isArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Option a -> OptReader a
optMain) Option a
p
    hasArg (MultP Parser (x -> a)
p1 Parser x
p2) = forall a. Parser a -> Bool
hasArg Parser (x -> a)
p1 Bool -> Bool -> Bool
|| forall a. Parser a -> Bool
hasArg Parser x
p2
    hasArg (AltP Parser a
p1 Parser a
p2) = forall a. Parser a -> Bool
hasArg Parser a
p1 Bool -> Bool -> Bool
|| forall a. Parser a -> Bool
hasArg Parser a
p2
    hasArg (BindP Parser x
p x -> Parser a
_) = forall a. Parser a -> Bool
hasArg Parser x
p

simplify :: OptTree a -> OptTree a
simplify :: forall a. OptTree a -> OptTree a
simplify (Leaf a
x) = forall a. a -> OptTree a
Leaf a
x
simplify (MultNode [OptTree a]
xs) =
  case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a}. OptTree a -> [OptTree a]
remove_mult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OptTree a -> OptTree a
simplify) [OptTree a]
xs of
    [OptTree a
x] -> OptTree a
x
    [OptTree a]
xs' -> forall a. [OptTree a] -> OptTree a
MultNode [OptTree a]
xs'
  where
    remove_mult :: OptTree a -> [OptTree a]
remove_mult (MultNode [OptTree a]
ts) = [OptTree a]
ts
    remove_mult OptTree a
t = [OptTree a
t]
simplify (AltNode AltNodeType
b [OptTree a]
xs) =
  forall a. AltNodeType -> [OptTree a] -> OptTree a
AltNode AltNodeType
b (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a}. OptTree a -> [OptTree a]
remove_alt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OptTree a -> OptTree a
simplify) [OptTree a]
xs)
  where
    remove_alt :: OptTree a -> [OptTree a]
remove_alt (AltNode AltNodeType
_ [OptTree a]
ts) = [OptTree a]
ts
    remove_alt (MultNode []) = []
    remove_alt OptTree a
t = [OptTree a
t]
simplify (BindNode OptTree a
x) =
  forall a. OptTree a -> OptTree a
BindNode forall a b. (a -> b) -> a -> b
$ forall a. OptTree a -> OptTree a
simplify OptTree a
x