{-# LANGUAGE Rank2Types #-}
module Options.Applicative.Common (
Parser,
liftOpt,
showOption,
ParserInfo(..),
ParserPrefs(..),
runParserInfo,
runParserFully,
runParserStep,
runParser,
evalParser,
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
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
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
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 ())
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
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
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
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