{-# 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,
  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 n :: String
n) = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
showOption (OptShort n :: Char
n) = '-' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
n]

optionNames :: OptReader a -> [OptName]
optionNames :: OptReader a -> [OptName]
optionNames (OptReader names :: [OptName]
names _ _) = [OptName]
names
optionNames (FlagReader names :: [OptName]
names _) = [OptName]
names
optionNames _ = []

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

-- | Create a parser composed of a single option.
liftOpt :: Option a -> Parser a
liftOpt :: 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 :: Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
optMatches disambiguate :: Bool
disambiguate opt :: OptReader a
opt (OptWord arg1 :: OptName
arg1 val :: Maybe String
val) = case OptReader a
opt of
  OptReader names :: [OptName]
names rdr :: CReader a
rdr no_arg_err :: 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 (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)
      (arg' :: String
arg', args' :: 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 (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 (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 (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 names :: [OptName]
names x :: 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 -> 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 (m :: * -> *) a. Monad m => a -> m a
return a
x
  _ -> Maybe (StateT Args m a)
forall a. Maybe a
Nothing
  where
    errorFor :: OptName -> String -> String
errorFor name :: OptName
name msg :: String
msg = "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
forall a. [a] -> [a] -> [a]
++ String
msg

    has_name :: OptName -> t OptName -> Bool
has_name a :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem OptName
a

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

data OptWord = OptWord OptName (Maybe String)

parseWord :: String -> Maybe OptWord
parseWord :: String -> Maybe OptWord
parseWord ('-' : '-' : w :: 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
  (opt :: String
opt, arg :: 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
/= '=') String
w of
    (_, "") -> (String
w, Maybe String
forall a. Maybe a
Nothing)
    (w' :: String
w', _ : rest :: 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 ('-' : w :: String
w) = case String
w of
  [] -> Maybe OptWord
forall a. Maybe a
Nothing
  (a :: Char
a : rest :: 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 (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 (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 _ = 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 r. Option r -> NondetT m (Parser r))
-> Parser a -> NondetT m (Parser a)
searchParser _ (NilP _) = NondetT m (Parser a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
searchParser f :: forall r. Option r -> NondetT m (Parser r)
f (OptP opt :: Option a
opt) = Option a -> NondetT m (Parser a)
forall r. Option r -> NondetT m (Parser r)
f Option a
opt
searchParser f :: forall r. Option r -> NondetT m (Parser r)
f (MultP p1 :: Parser (x -> a)
p1 p2 :: Parser x
p2) = (NondetT m (Parser a)
 -> NondetT m (Parser a) -> NondetT m (Parser a))
-> [NondetT m (Parser a)] -> NondetT m (Parser 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 forall r. Option r -> NondetT m (Parser r)
f Parser (x -> a)
p1
       Parser a -> NondetT m (Parser a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1' Parser (x -> a) -> Parser x -> Parser a
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 forall r. Option r -> NondetT m (Parser r)
f Parser x
p2
       Parser a -> NondetT m (Parser a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Parser (x -> a)
p1 Parser (x -> a) -> Parser x -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser x
p2') ]
searchParser f :: forall r. Option r -> NondetT m (Parser r)
f (AltP p1 :: Parser a
p1 p2 :: 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 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 forall r. Option r -> NondetT m (Parser r)
f Parser a
p2 ]
searchParser f :: forall r. Option r -> NondetT m (Parser r)
f (BindP p :: Parser x
p k :: 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 forall r. Option r -> NondetT m (Parser r)
f Parser x
p
       Parser a -> NondetT m (Parser 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
      Nothing -> NondetT m (Parser a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      Just aa :: 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 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 :: ParserPrefs
-> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)
searchOpt pprefs :: ParserPrefs
pprefs w :: 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
$ \opt :: 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 matcher :: StateT Args m r
matcher -> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT Args m r
matcher
    Nothing -> NondetT (StateT Args m) (Parser r)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

searchArg :: MonadP m => ParserPrefs -> String -> Parser a
          -> NondetT (StateT Args m) (Parser a)
searchArg :: ParserPrefs
-> String -> Parser a -> NondetT (StateT Args m) (Parser a)
searchArg prefs :: ParserPrefs
prefs arg :: 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
$ \opt :: 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 _ _ f :: String -> Maybe (ParserInfo r)
f ->
      case (String -> Maybe (ParserInfo r)
f String
arg, ParserPrefs -> Backtracking
prefBacktrack ParserPrefs
prefs) of
        (Just subp :: ParserInfo r
subp, NoBacktrack) -> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
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 (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 (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp m () -> m r -> m r
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall (m :: * -> *). MonadP m => m ()
exitContext

        (Just subp :: ParserInfo r
subp, Backtrack) -> (r -> Parser r)
-> NondetT (StateT Args m) r -> NondetT (StateT Args m) (Parser r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
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 (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
args ->
          String -> ParserInfo r -> m ()
forall (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp m () -> m (r, Args) -> m (r, Args)
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall (m :: * -> *). MonadP m => m ()
exitContext

        (Just subp :: ParserInfo r
subp, SubparserInline) -> StateT Args m (Parser r) -> NondetT (StateT Args m) (Parser r)
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 (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 (m :: * -> *) a. MonadP m => String -> ParserInfo a -> m ()
enterContext String
arg ParserInfo r
subp
          Parser r -> StateT Args m (Parser r)
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

        (Nothing, _)  -> NondetT (StateT Args m) (Parser r)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    ArgReader rdr :: CReader r
rdr ->
      (r -> Parser r)
-> NondetT (StateT Args m) r -> NondetT (StateT Args m) (Parser r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Parser r
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 (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 (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
    _ -> NondetT (StateT Args m) (Parser r)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
           -> Parser a -> NondetT (StateT Args m) (Parser a)
stepParser :: ParserPrefs
-> ArgPolicy
-> String
-> Parser a
-> NondetT (StateT Args m) (Parser a)
stepParser pprefs :: ParserPrefs
pprefs AllPositionals arg :: String
arg p :: 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 pprefs :: ParserPrefs
pprefs ForwardOptions arg :: String
arg p :: Parser a
p = case String -> Maybe OptWord
parseWord String
arg of
  Just w :: 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 (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
  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 pprefs :: ParserPrefs
pprefs _ arg :: String
arg p :: Parser a
p = case String -> Maybe OptWord
parseWord String
arg of
  Just w :: 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
  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 :: ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
runParser policy :: ArgPolicy
policy _ p :: Parser a
p ("--" : argt :: 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 policy :: ArgPolicy
policy isCmdStart :: IsCmdStart
isCmdStart p :: Parser a
p args :: Args
args = case Args
args of
  [] -> IsCmdStart
-> ArgPolicy -> Parser a -> Maybe (a, Args) -> m (a, Args)
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
  (arg :: String
arg : argt :: Args
argt) -> do
    ParserPrefs
prefs <- m ParserPrefs
forall (m :: * -> *). MonadP m => m ParserPrefs
getPrefs
    (mp' :: Maybe (Parser a)
mp', args' :: Args
args') <- ParserPrefs -> String -> Args -> m (Maybe (Parser a), Args)
forall (m :: * -> *).
MonadP m =>
ParserPrefs -> String -> Args -> m (Maybe (Parser a), Args)
do_step ParserPrefs
prefs String
arg Args
argt
    case Maybe (Parser a)
mp' of
      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 (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 p' :: 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Args -> Maybe Args
forall (f :: * -> *) a. Applicative f => a -> f a
pure Args
args
    do_step :: ParserPrefs -> String -> Args -> m (Maybe (Parser a), Args)
do_step prefs :: ParserPrefs
prefs arg :: String
arg argt :: Args
argt = (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
argt)
                           (StateT Args m (Maybe (Parser a)) -> m (Maybe (Parser a), Args))
-> (NondetT (StateT Args m) (Parser a)
    -> StateT Args m (Maybe (Parser a)))
-> NondetT (StateT Args m) (Parser a)
-> m (Maybe (Parser a), Args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) -> m (Maybe (Parser a), Args))
-> NondetT (StateT Args m) (Parser a) -> m (Maybe (Parser a), Args)
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

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

parseError :: MonadP m => String -> Parser x -> m a
parseError :: String -> Parser x -> m a
parseError arg :: String
arg = 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 :: ParserInfo a -> Args -> m a
runParserInfo i :: 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 :: ArgPolicy -> Parser a -> Args -> m a
runParserFully policy :: ArgPolicy
policy p :: Parser a
p args :: Args
args = do
  (r :: a
r, args' :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
r
    a :: String
a:_ -> String -> Parser () -> m a
forall (m :: * -> *) x a. MonadP m => String -> Parser x -> m a
parseError String
a (() -> Parser ()
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 :: Parser a -> Maybe a
evalParser (NilP r :: Maybe a
r) = Maybe a
r
evalParser (OptP _) = Maybe a
forall a. Maybe a
Nothing
evalParser (MultP p1 :: Parser (x -> a)
p1 p2 :: 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 (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 p1 :: Parser a
p1 p2 :: Parser a
p2) = Parser a -> Maybe a
forall a. Parser a -> Maybe a
evalParser Parser a
p1 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 p :: Parser x
p k :: 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 (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. OptHelpInfo -> Option x -> b)
          -> Parser a -> [b]
mapParser :: (forall x. OptHelpInfo -> Option x -> b) -> Parser a -> [b]
mapParser f :: forall x. OptHelpInfo -> Option x -> b
f = OptTree b -> [b]
forall b. OptTree b -> [b]
flatten (OptTree b -> [b]) -> (Parser a -> OptTree b) -> Parser a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b
forall b a.
(forall x. OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b
treeMapParser forall x. OptHelpInfo -> Option x -> b
f
  where
    flatten :: OptTree b -> [b]
flatten (Leaf x :: b
x) = [b
x]
    flatten (MultNode xs :: [OptTree b]
xs) = [OptTree b]
xs [OptTree b] -> (OptTree b -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OptTree b -> [b]
flatten
    flatten (AltNode _ xs :: [OptTree b]
xs) = [OptTree b]
xs [OptTree b] -> (OptTree b -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OptTree b -> [b]
flatten

-- | Like 'mapParser', but collect the results in a tree structure.
treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)
          -> Parser a
          -> OptTree b
treeMapParser :: (forall x. OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b
treeMapParser g :: forall x. OptHelpInfo -> 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
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
False Bool
False forall x. OptHelpInfo -> Option x -> b
g
  where
    has_default :: Parser a -> Bool
    has_default :: Parser a -> Bool
has_default p :: 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
       -> Bool
       -> (forall x . OptHelpInfo -> Option x -> b)
       -> Parser a
       -> OptTree b
    go :: Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go _ _ _ (NilP _) = [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode []
    go m :: Bool
m r :: Bool
r f :: forall x. OptHelpInfo -> Option x -> b
f (OptP opt :: 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 (OptHelpInfo -> Option a -> b
forall x. OptHelpInfo -> Option x -> b
f (Bool -> Bool -> OptHelpInfo
OptHelpInfo Bool
m Bool
r) Option a
opt)
      | Bool
otherwise
      = [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode []
    go m :: Bool
m r :: Bool
r f :: forall x. OptHelpInfo -> Option x -> b
f (MultP p1 :: Parser (x -> a)
p1 p2 :: Parser x
p2) =
      [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode [Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser (x -> a)
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
m Bool
r forall x. OptHelpInfo -> Option x -> b
f Parser (x -> a)
p1, Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser x
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
m Bool
r' forall x. OptHelpInfo -> 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 m :: Bool
m r :: Bool
r f :: forall x. OptHelpInfo -> Option x -> b
f (AltP p1 :: Parser a
p1 p2 :: Parser a
p2) =
      AltNodeType -> [OptTree b] -> OptTree b
forall a. AltNodeType -> [OptTree a] -> OptTree a
AltNode AltNodeType
altNodeType [Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
m Bool
r forall x. OptHelpInfo -> Option x -> b
f Parser a
p1, Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
m Bool
r forall x. OptHelpInfo -> 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 _ r :: Bool
r f :: forall x. OptHelpInfo -> Option x -> b
f (BindP p :: Parser x
p k :: x -> Parser a
k) =
      let go' :: OptTree b
go' = Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser x
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
True Bool
r forall x. OptHelpInfo -> Option x -> b
f Parser x
p
      in case Parser x -> Maybe x
forall a. Parser a -> Maybe a
evalParser Parser x
p of
        Nothing -> OptTree b
go'
        Just aa :: x
aa -> [OptTree b] -> OptTree b
forall a. [OptTree a] -> OptTree a
MultNode [ OptTree b
go', Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
forall b a.
Bool
-> Bool
-> (forall x. OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
go Bool
True Bool
r forall x. OptHelpInfo -> Option x -> b
f (x -> Parser a
k x
aa) ]

    hasArg :: Parser a -> Bool
    hasArg :: Parser a -> Bool
hasArg (NilP _) = Bool
False
    hasArg (OptP p :: 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 p1 :: Parser (x -> a)
p1 p2 :: 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 p1 :: Parser a
p1 p2 :: 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 p :: Parser x
p _) = Parser x -> Bool
forall a. Parser a -> Bool
hasArg Parser x
p

simplify :: OptTree a -> OptTree a
simplify :: OptTree a -> OptTree a
simplify (Leaf x :: a
x) = a -> OptTree a
forall a. a -> OptTree a
Leaf a
x
simplify (MultNode xs :: [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
    [x :: OptTree a
x] -> OptTree a
x
    xs' :: [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 ts :: [OptTree a]
ts) = [OptTree a]
ts
    remove_mult t :: OptTree a
t = [OptTree a
t]
simplify (AltNode b :: AltNodeType
b xs :: [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 _ ts :: [OptTree a]
ts) = [OptTree a]
ts
    remove_alt (MultNode []) = []
    remove_alt t :: OptTree a
t = [OptTree a
t]