{-# 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
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
showOption (OptShort Char
n) = Char
'-' Char -> String -> String
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y
isOptionPrefix (OptLong String
x) (OptLong String
y) = String
x String -> String -> Bool
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 = Option a -> Parser a
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
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ OptName -> [OptName] -> Bool
forall {t :: * -> *}. Foldable t => OptName -> t OptName -> Bool
has_name OptName
arg1 [OptName]
names
    StateT Args m a -> Maybe (StateT Args m a)
forall a. a -> Maybe a
Just (StateT Args m a -> Maybe (StateT Args m a))
-> StateT Args m a -> Maybe (StateT Args m a)
forall a b. (a -> b) -> a -> b
$ do
      Args
args <- StateT Args m Args
forall (m :: * -> *) s. Monad m => StateT s m s
get
      let mb_args :: Maybe (String, Args)
mb_args = Args -> Maybe (String, Args)
forall a. [a] -> Maybe (a, [a])
uncons (Args -> Maybe (String, Args)) -> Args -> Maybe (String, Args)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Args
forall a. Maybe a -> [a]
maybeToList Maybe String
val Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ Args
args
      let missing_arg :: m a
missing_arg = ParseError -> Completer -> m a
forall a. ParseError -> Completer -> m a
forall (m :: * -> *) a. MonadP m => ParseError -> Completer -> m a
missingArgP (String -> ParseError
no_arg_err (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ OptName -> String
showOption OptName
arg1) (CReader a -> Completer
forall a. CReader a -> Completer
crCompleter CReader a
rdr)
      (String
arg', Args
args') <- StateT Args m (String, Args)
-> ((String, Args) -> StateT Args m (String, Args))
-> Maybe (String, Args)
-> StateT Args m (String, Args)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (m (String, Args) -> StateT Args m (String, Args)
forall (m :: * -> *) a. Monad m => m a -> StateT Args m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (String, Args)
forall {a}. m a
missing_arg) (String, Args) -> StateT Args m (String, Args)
forall a. a -> StateT Args m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, Args)
mb_args
      Args -> StateT Args m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Args
args'
      m a -> StateT Args m a
forall (m :: * -> *) a. Monad m => m a -> StateT Args m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT Args m a) -> m a -> StateT Args m a
forall a b. (a -> b) -> a -> b
$ ReadM a -> String -> m a
forall (m :: * -> *) a. MonadP m => ReadM a -> String -> m a
runReadM ((String -> String) -> ReadM a -> ReadM a
forall a. (String -> String) -> ReadM a -> ReadM a
withReadM (OptName -> String -> String
errorFor OptName
arg1) (CReader a -> ReadM a
forall a. CReader a -> ReadM a
crReader CReader a
rdr)) String
arg'

  FlagReader [OptName]
names a
x -> do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ OptName -> [OptName] -> Bool
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.
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ OptName -> Bool
isShortName OptName
arg1 Bool -> Bool -> Bool
|| Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
val
    StateT Args m a -> Maybe (StateT Args m a)
forall a. a -> Maybe a
Just (StateT Args m a -> Maybe (StateT Args m a))
-> StateT Args m a -> Maybe (StateT Args m a)
forall a b. (a -> b) -> a -> b
$ do
      Args
args <- StateT Args m Args
forall (m :: * -> *) s. Monad m => StateT s m s
get
      let val' :: Maybe String
val' = (Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
val
      Args -> StateT Args m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Args -> StateT Args m ()) -> Args -> StateT Args m ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Args
forall a. Maybe a -> [a]
maybeToList Maybe String
val' Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ Args
args
      a -> StateT Args m a
forall a. a -> StateT Args m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  OptReader a
_ -> Maybe (StateT Args m a)
forall a. Maybe a
Nothing
  where
    errorFor :: OptName -> String -> String
errorFor OptName
name String
msg = String
"option " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptName -> String
showOption OptName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

    has_name :: OptName -> t OptName -> Bool
has_name OptName
a
      | Bool
disambiguate = (OptName -> Bool) -> t OptName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (OptName -> OptName -> Bool
isOptionPrefix OptName
a)
      | Bool
otherwise = OptName -> t OptName -> Bool
forall a. Eq a => a -> t a -> Bool
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) = OptWord -> Maybe OptWord
forall a. a -> Maybe a
Just (OptWord -> Maybe OptWord) -> OptWord -> Maybe OptWord
forall a b. (a -> b) -> a -> b
$ let
  (String
opt, Maybe String
arg) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
w of
    (String
_, String
"") -> (String
w, Maybe String
forall a. Maybe a
Nothing)
    (String
w', Char
_ : String
rest) -> (String
w', String -> Maybe String
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
  [] -> Maybe OptWord
forall a. Maybe a
Nothing
  (Char
a : String
rest) -> OptWord -> Maybe OptWord
forall a. a -> Maybe a
Just (OptWord -> Maybe OptWord) -> OptWord -> Maybe OptWord
forall a b. (a -> b) -> a -> b
$ let
    arg :: Maybe String
arg = String
rest String -> Maybe () -> Maybe String
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
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
_ = Maybe OptWord
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
_) = NondetT m (Parser a)
forall a. NondetT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
searchParser forall r. Option r -> NondetT m (Parser r)
f (OptP Option a
opt) = Option a -> NondetT m (Parser a)
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) = (NondetT m (Parser a)
 -> NondetT m (Parser a) -> NondetT m (Parser a))
-> [NondetT m (Parser a)] -> NondetT m (Parser a)
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 NondetT m (Parser a)
-> NondetT m (Parser a) -> NondetT m (Parser a)
forall (m :: * -> *) a.
Monad m =>
NondetT m a -> NondetT m a -> NondetT m a
(<!>)
  [ do Parser (x -> a)
p1' <- (forall r. Option r -> NondetT m (Parser r))
-> Parser (x -> a) -> NondetT m (Parser (x -> a))
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
forall r. Option r -> NondetT m (Parser r)
f Parser (x -> a)
p1
       Parser a -> NondetT m (Parser a)
forall a. a -> NondetT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1' Parser (x -> a) -> Parser x -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser x
p2)
  , do Parser x
p2' <- (forall r. Option r -> NondetT m (Parser r))
-> Parser x -> NondetT m (Parser x)
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
forall r. Option r -> NondetT m (Parser r)
f Parser x
p2
       Parser a -> NondetT m (Parser a)
forall a. a -> NondetT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1 Parser (x -> a) -> Parser x -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
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) = [NondetT m (Parser a)] -> NondetT m (Parser a)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ (forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
forall r. Option r -> NondetT m (Parser r)
f Parser a
p1
  , (forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
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) = [NondetT m (Parser a)] -> NondetT m (Parser a)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
  [ do Parser x
p' <- (forall r. Option r -> NondetT m (Parser r))
-> Parser x -> NondetT m (Parser x)
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
forall r. Option r -> NondetT m (Parser r)
f Parser x
p
       Parser a -> NondetT m (Parser a)
forall a. a -> NondetT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parser a -> NondetT m (Parser a))
-> Parser a -> NondetT m (Parser a)
forall a b. (a -> b) -> a -> b
$ Parser x -> (x -> Parser a) -> Parser a
forall a x. Parser x -> (x -> Parser a) -> Parser a
BindP Parser x
p' x -> Parser a
k
  , case Parser x -> Maybe x
forall a. Parser a -> Maybe a
evalParser Parser x
p of
      Maybe x
Nothing -> NondetT m (Parser a)
forall a. NondetT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      Just x
aa -> (forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
forall (m :: * -> *) a.
Monad m =>
(forall r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser Option r -> NondetT m (Parser r)
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 r. Option r -> NondetT (StateT Args m) (Parser r))
-> Parser a -> NondetT (StateT Args m) (Parser a)
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 (StateT Args m) (Parser r))
 -> Parser a -> NondetT (StateT Args m) (Parser a))
-> (forall r. Option r -> NondetT (StateT Args m) (Parser r))
-> Parser a
-> NondetT (StateT Args m) (Parser a)
forall a b. (a -> b) -> a -> b
$ \Option r
opt -> do
  let disambiguate :: Bool
disambiguate = ParserPrefs -> Bool
prefDisambiguate ParserPrefs
pprefs
                  Bool -> Bool -> Bool
&& Option r -> OptVisibility
forall a. Option a -> OptVisibility
optVisibility Option r
opt OptVisibility -> OptVisibility -> Bool
forall a. Ord a => a -> a -> Bool
> OptVisibility
Internal
  case Bool -> OptReader r -> OptWord -> Maybe (StateT Args m r)
forall (m :: * -> *) a.
MonadP m =>
Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
optMatches Bool
disambiguate (Option r -> OptReader r
forall a. Option a -> OptReader a
optMain Option r
opt) OptWord
w of
    Just StateT Args m r
matcher -> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
forall (m :: * -> *) a. Monad m => m a -> NondetT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r))
-> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
forall a b. (a -> b) -> a -> b
$ (r -> Parser r) -> StateT Args m r -> StateT Args m (Parser r)
forall a b. (a -> b) -> StateT Args m a -> StateT Args m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT Args m r
matcher
    Maybe (StateT Args m r)
Nothing -> NondetT (StateT Args m) (Parser r)
forall a. NondetT (StateT Args m) a
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 r. Option r -> NondetT (StateT Args m) (Parser r))
-> Parser a -> NondetT (StateT Args m) (Parser a)
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 (StateT Args m) (Parser r))
 -> Parser a -> NondetT (StateT Args m) (Parser a))
-> (forall r. Option r -> NondetT (StateT Args m) (Parser r))
-> Parser a
-> NondetT (StateT Args m) (Parser a)
forall a b. (a -> b) -> a -> b
$ \Option r
opt -> do
    Bool -> NondetT (StateT Args m) () -> NondetT (StateT Args m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OptReader r -> Bool
forall a. OptReader a -> Bool
isArg (Option r -> OptReader r
forall a. Option a -> OptReader a
optMain Option r
opt)) NondetT (StateT Args m) ()
forall (m :: * -> *). Monad m => NondetT m ()
cut
    case Option r -> OptReader r
forall a. Option a -> OptReader a
optMain Option r
opt of
      CmdReader Maybe String
_ [(String, ParserInfo r)]
cs -> do
        ParserInfo r
subp <- [ParserInfo r] -> NondetT (StateT Args m) (ParserInfo r)
forall (m :: * -> *) a. Alternative m => [a] -> m a
hoistList ([(String, ParserInfo r)] -> [ParserInfo r]
forall {b}. [(String, b)] -> [b]
cmdMatches [(String, ParserInfo r)]
cs)
        case ParserPrefs -> Backtracking
prefBacktrack ParserPrefs
prefs of
          Backtracking
NoBacktrack -> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
forall (m :: * -> *) a. Monad m => m a -> NondetT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r))
-> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
forall a b. (a -> b) -> a -> b
$ do
            Args
args <- StateT Args m Args
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT Args m Args -> StateT Args m () -> StateT Args m Args
forall a b. StateT Args m a -> StateT Args m b -> StateT Args m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Args -> StateT Args m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put []
            (r -> Parser r) -> StateT Args m r -> StateT Args m (Parser r)
forall a b. (a -> b) -> StateT Args m a -> StateT Args m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT Args m r -> StateT Args m (Parser r))
-> (m r -> StateT Args m r) -> m r -> StateT Args m (Parser r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m r -> StateT Args m r
forall (m :: * -> *) a. Monad m => m a -> StateT Args m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> StateT Args m (Parser r))
-> m r -> StateT Args m (Parser r)
forall a b. (a -> b) -> a -> b
$ String -> ParserInfo r -> m ()
forall a. String -> ParserInfo a -> m ()
forall (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp m () -> m r -> m r
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserInfo r -> Args -> m r
forall (m :: * -> *) a. MonadP m => ParserInfo a -> Args -> m a
runParserInfo ParserInfo r
subp Args
args m r -> m () -> m r
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall (m :: * -> *). MonadP m => m ()
exitContext

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

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

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

  where
    cmdMatches :: [(String, b)] -> [b]
cmdMatches [(String, b)]
cs
      | ParserPrefs -> Bool
prefDisambiguate ParserPrefs
prefs = (String, b) -> b
forall a b. (a, b) -> b
snd ((String, b) -> b) -> [(String, b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, b) -> Bool) -> [(String, b)] -> [(String, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
arg (String -> Bool) -> ((String, b) -> String) -> (String, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst) [(String, b)]
cs
      | Bool
otherwise = Maybe b -> [b]
forall a. Maybe a -> [a]
maybeToList (String -> [(String, b)] -> Maybe b
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 =
  ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
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 -> ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
forall (m :: * -> *) a.
MonadP m =>
ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
searchOpt ParserPrefs
pprefs OptWord
w Parser a
p NondetT (StateT Args m) (Parser a)
-> NondetT (StateT Args m) (Parser a)
-> NondetT (StateT Args m) (Parser a)
forall a.
NondetT (StateT Args m) a
-> NondetT (StateT Args m) a -> NondetT (StateT Args m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser 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 -> ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
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 -> ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
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 -> ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
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 ArgPolicy -> ArgPolicy -> Bool
forall a. Eq a => a -> a -> Bool
/= ArgPolicy
AllPositionals
                                   = ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
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
  [] -> IsCmdStart
-> ArgPolicy -> Parser a -> Maybe (a, Args) -> m (a, Args)
forall b a. IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a
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 -> Maybe (a, Args) -> m (a, Args)
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
hoistMaybe Maybe (a, Args)
result m (a, Args) -> m (a, Args) -> m (a, Args)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser a -> m (a, Args)
forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
arg Parser a
p
      Just Parser a
p' -> ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
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 =
      (,) (a -> Args -> (a, Args)) -> Maybe a -> Maybe (Args -> (a, Args))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Maybe a
forall a. Parser a -> Maybe a
evalParser Parser a
p Maybe (Args -> (a, Args)) -> Maybe Args -> Maybe (a, Args)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Args -> Maybe Args
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Args
args
    do_step :: String -> Args -> m (Maybe (Parser a), Args)
do_step =
      ArgPolicy
-> Parser a -> String -> Args -> m (Maybe (Parser a), Args)
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 Maybe OptWord -> Bool
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 <- m ParserPrefs
forall (m :: * -> *). MonadP m => m ParserPrefs
getPrefs
  (StateT Args m (Maybe (Parser a))
 -> Args -> m (Maybe (Parser a), Args))
-> Args
-> StateT Args m (Maybe (Parser a))
-> m (Maybe (Parser a), Args)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Args m (Maybe (Parser a))
-> Args -> m (Maybe (Parser a), Args)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Args
args
    (StateT Args m (Maybe (Parser a)) -> m (Maybe (Parser a), Args))
-> StateT Args m (Maybe (Parser a)) -> m (Maybe (Parser a), Args)
forall a b. (a -> b) -> a -> b
$ Bool
-> NondetT (StateT Args m) (Parser a)
-> StateT Args m (Maybe (Parser a))
forall (m :: * -> *) a.
Monad m =>
Bool -> NondetT m a -> m (Maybe a)
disamb (Bool -> Bool
not (ParserPrefs -> Bool
prefDisambiguate ParserPrefs
prefs))
    (NondetT (StateT Args m) (Parser a)
 -> StateT Args m (Maybe (Parser a)))
-> NondetT (StateT Args m) (Parser a)
-> StateT Args m (Maybe (Parser a))
forall a b. (a -> b) -> a -> b
$ ParserPrefs
-> ArgPolicy
-> String
-> Parser a
-> NondetT (StateT Args m) (Parser a)
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 = ParseError -> m a
forall a. ParseError -> m a
forall (m :: * -> *) a. MonadP m => ParseError -> m a
errorP (ParseError -> m a) -> (Parser x -> ParseError) -> Parser x -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SomeParser -> ParseError
UnexpectedError String
arg (SomeParser -> ParseError)
-> (Parser x -> SomeParser) -> Parser x -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser x -> SomeParser
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 = ArgPolicy -> Parser a -> Args -> m a
forall (m :: * -> *) a.
MonadP m =>
ArgPolicy -> Parser a -> Args -> m a
runParserFully (ParserInfo a -> ArgPolicy
forall a. ParserInfo a -> ArgPolicy
infoPolicy ParserInfo a
i) (ParserInfo a -> Parser a
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') <- ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, 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
    []  -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
    String
a:Args
_ -> String -> Parser () -> m a
forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
a (() -> Parser ()
forall a. a -> Parser 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
_) = Maybe a
forall a. Maybe a
Nothing
evalParser (MultP Parser (x -> a)
p1 Parser x
p2) = Parser (x -> a) -> Maybe (x -> a)
forall a. Parser a -> Maybe a
evalParser Parser (x -> a)
p1 Maybe (x -> a) -> Maybe x -> Maybe a
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser x -> Maybe x
forall a. Parser a -> Maybe a
evalParser Parser x
p2
evalParser (AltP Parser a
p1 Parser a
p2) = Parser a -> Maybe a
forall a. Parser a -> Maybe a
evalParser Parser a
p1 Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a -> Maybe a
forall a. Parser a -> Maybe a
evalParser Parser a
p2
evalParser (BindP Parser x
p x -> Parser a
k) = Parser x -> Maybe x
forall a. Parser a -> Maybe a
evalParser Parser x
p Maybe x -> (x -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser a -> Maybe a
forall a. Parser a -> Maybe a
evalParser (Parser a -> Maybe a) -> (x -> Parser a) -> x -> Maybe a
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 = OptTree b -> [b]
forall {a}. OptTree a -> [a]
flatten (OptTree b -> [b]) -> (Parser a -> OptTree b) -> Parser a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
treeMapParser ArgumentReachability -> Option x -> b
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 [OptTree a] -> (OptTree a -> [a]) -> [a]
forall a b. [a] -> (a -> [b]) -> [b]
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 [OptTree a] -> (OptTree a -> [a]) -> [a]
forall a b. [a] -> (a -> [b]) -> [b]
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 = OptTree b -> OptTree b
forall a. OptTree a -> OptTree a
simplify (OptTree b -> OptTree b)
-> (Parser a -> OptTree b) -> Parser a -> OptTree b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
False ArgumentReachability -> Option x -> b
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 = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Parser a -> Maybe a
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
_) = [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode []
    go Bool
r forall x. ArgumentReachability -> Option x -> b
f (OptP Option a
opt)
      | Option a -> OptVisibility
forall a. Option a -> OptVisibility
optVisibility Option a
opt OptVisibility -> OptVisibility -> Bool
forall a. Ord a => a -> a -> Bool
> OptVisibility
Internal
      = b -> OptTree b
forall a. a -> OptTree a
Leaf (ArgumentReachability -> Option a -> b
forall x. ArgumentReachability -> Option x -> b
f (Bool -> ArgumentReachability
ArgumentReachability Bool
r) Option a
opt)
      | Bool
otherwise
      = [OptTree b] -> OptTree b
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) =
      [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode [Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser (x -> a)
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r ArgumentReachability -> Option x -> b
forall x. ArgumentReachability -> Option x -> b
f Parser (x -> a)
p1, Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser x
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r' ArgumentReachability -> Option x -> b
forall x. ArgumentReachability -> Option x -> b
f Parser x
p2]
      where r' :: Bool
r' = Bool
r Bool -> Bool -> Bool
|| Parser (x -> a) -> 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) =
      AltNodeType -> [OptTree b] -> OptTree b
forall a. AltNodeType -> [OptTree a] -> OptTree a
AltNode AltNodeType
altNodeType [Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r ArgumentReachability -> Option x -> b
forall x. ArgumentReachability -> Option x -> b
f Parser a
p1, Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r ArgumentReachability -> Option x -> b
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 Parser a -> Bool
forall a. Parser a -> Bool
has_default Parser a
p1 Bool -> Bool -> Bool
|| Parser a -> 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' = Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser x
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r ArgumentReachability -> Option x -> b
forall x. ArgumentReachability -> Option x -> b
f Parser x
p
      in case Parser x -> Maybe x
forall a. Parser a -> Maybe a
evalParser Parser x
p of
        Maybe x
Nothing -> OptTree b -> OptTree b
forall a. OptTree a -> OptTree a
BindNode OptTree b
go'
        Just x
aa -> OptTree b -> OptTree b
forall a. OptTree a -> OptTree a
BindNode ([OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode [ OptTree b
go', Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> (forall x. ArgumentReachability -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
r ArgumentReachability -> Option x -> b
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) = (OptReader a -> Bool
forall a. OptReader a -> Bool
isArg (OptReader a -> Bool)
-> (Option a -> OptReader a) -> Option a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option a -> OptReader a
forall a. Option a -> OptReader a
optMain) Option a
p
    hasArg (MultP Parser (x -> a)
p1 Parser x
p2) = Parser (x -> a) -> Bool
forall a. Parser a -> Bool
hasArg Parser (x -> a)
p1 Bool -> Bool -> Bool
|| Parser x -> Bool
forall a. Parser a -> Bool
hasArg Parser x
p2
    hasArg (AltP Parser a
p1 Parser a
p2) = Parser a -> Bool
forall a. Parser a -> Bool
hasArg Parser a
p1 Bool -> Bool -> Bool
|| Parser a -> Bool
forall a. Parser a -> Bool
hasArg Parser a
p2
    hasArg (BindP Parser x
p x -> Parser a
_) = Parser x -> Bool
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) = a -> OptTree a
forall a. a -> OptTree a
Leaf a
x
simplify (MultNode [OptTree a]
xs) =
  case (OptTree a -> [OptTree a]) -> [OptTree a] -> [OptTree a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OptTree a -> [OptTree a]
forall {a}. OptTree a -> [OptTree a]
remove_mult (OptTree a -> [OptTree a])
-> (OptTree a -> OptTree a) -> OptTree a -> [OptTree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptTree a -> OptTree a
forall a. OptTree a -> OptTree a
simplify) [OptTree a]
xs of
    [OptTree a
x] -> OptTree a
x
    [OptTree a]
xs' -> [OptTree a] -> OptTree a
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) =
  AltNodeType -> [OptTree a] -> OptTree a
forall a. AltNodeType -> [OptTree a] -> OptTree a
AltNode AltNodeType
b ((OptTree a -> [OptTree a]) -> [OptTree a] -> [OptTree a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OptTree a -> [OptTree a]
forall {a}. OptTree a -> [OptTree a]
remove_alt (OptTree a -> [OptTree a])
-> (OptTree a -> OptTree a) -> OptTree a -> [OptTree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptTree a -> OptTree a
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) =
  OptTree a -> OptTree a
forall a. OptTree a -> OptTree a
BindNode (OptTree a -> OptTree a) -> OptTree a -> OptTree a
forall a b. (a -> b) -> a -> b
$ OptTree a -> OptTree a
forall a. OptTree a -> OptTree a
simplify OptTree a
x