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