module Options.Applicative.Internal
  ( P
  , MonadP(..)
  , ParseError(..)

  , uncons
  , hoistMaybe
  , hoistEither
  , runReadM
  , withReadM

  , runP

  , Completion
  , runCompletion
  , contextNames

  , ListT
  , takeListT
  , runListT

  , NondetT
  , cut
  , (<!>)
  , disamb
  ) where

import Control.Applicative
import Prelude
import Control.Monad (MonadPlus(..), liftM, ap, guard)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Except
  (runExcept, runExceptT, withExcept, ExceptT(..), throwE)
import Control.Monad.Trans.Reader
  (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)

import Options.Applicative.Types

class (Alternative m, MonadPlus m) => MonadP m where
  enterContext :: String -> ParserInfo a -> m ()
  exitContext :: m ()
  getPrefs :: m ParserPrefs

  missingArgP :: ParseError -> Completer -> m a
  errorP :: ParseError -> m a
  exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a

newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)

instance Functor P where
  fmap :: (a -> b) -> P a -> P b
fmap a -> b
f (P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
m) = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b -> P b
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
 -> P b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
-> P b
forall a b. (a -> b) -> a -> b
$ (a -> b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
m

instance Applicative P where
  pure :: a -> P a
pure a
a = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> P a)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> P a
forall a b. (a -> b) -> a -> b
$ a -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) (a -> b)
f <*> :: P (a -> b) -> P a -> P b
<*> P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
a = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b -> P b
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
 -> P b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
-> P b
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) (a -> b)
f ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) (a -> b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
a

instance Alternative P where
  empty :: P a
empty = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (f :: * -> *) a. Alternative f => f a
empty
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x <|> :: P a -> P a -> P a
<|> P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> P a)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> P a
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y

instance Monad P where
  return :: a -> P a
return = a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x >>= :: P a -> (a -> P b) -> P b
>>= a -> P b
k = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b -> P b
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
 -> P b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
-> P b
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> (a
    -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> case a -> P b
k a
a of P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
y -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) b
y

instance MonadPlus P where
  mzero :: P a
mzero = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: P a -> P a -> P a
mplus (P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x) (P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y) = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> P a)
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> P a
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y

contextNames :: [Context] -> [String]
contextNames :: [Context] -> [String]
contextNames [Context]
ns =
  let go :: Context -> String
go (Context String
n ParserInfo a
_) = String
n
  in  [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Context -> String
go (Context -> String) -> [Context] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Context]
ns

instance MonadP P where
  enterContext :: String -> ParserInfo a -> P ()
enterContext String
name ParserInfo a
pinfo = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
-> P ()
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
 -> P ())
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
-> P ()
forall a b. (a -> b) -> a -> b
$ StateT [Context] (Reader ParserPrefs) ()
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT [Context] (Reader ParserPrefs) ()
 -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ())
-> StateT [Context] (Reader ParserPrefs) ()
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
forall a b. (a -> b) -> a -> b
$ ([Context] -> [Context])
-> StateT [Context] (Reader ParserPrefs) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (([Context] -> [Context])
 -> StateT [Context] (Reader ParserPrefs) ())
-> ([Context] -> [Context])
-> StateT [Context] (Reader ParserPrefs) ()
forall a b. (a -> b) -> a -> b
$ (:) (Context -> [Context] -> [Context])
-> Context -> [Context] -> [Context]
forall a b. (a -> b) -> a -> b
$ String -> ParserInfo a -> Context
forall a. String -> ParserInfo a -> Context
Context String
name ParserInfo a
pinfo
  exitContext :: P ()
exitContext = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
-> P ()
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
 -> P ())
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
-> P ()
forall a b. (a -> b) -> a -> b
$ StateT [Context] (Reader ParserPrefs) ()
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT [Context] (Reader ParserPrefs) ()
 -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ())
-> StateT [Context] (Reader ParserPrefs) ()
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) ()
forall a b. (a -> b) -> a -> b
$ ([Context] -> [Context])
-> StateT [Context] (Reader ParserPrefs) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (([Context] -> [Context])
 -> StateT [Context] (Reader ParserPrefs) ())
-> ([Context] -> [Context])
-> StateT [Context] (Reader ParserPrefs) ()
forall a b. (a -> b) -> a -> b
$ Int -> [Context] -> [Context]
forall a. Int -> [a] -> [a]
drop Int
1
  getPrefs :: P ParserPrefs
getPrefs = ExceptT
  ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs
-> P ParserPrefs
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT
   ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs
 -> P ParserPrefs)
-> (Reader ParserPrefs ParserPrefs
    -> ExceptT
         ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs)
-> Reader ParserPrefs ParserPrefs
-> P ParserPrefs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT [Context] (Reader ParserPrefs) ParserPrefs
-> ExceptT
     ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT [Context] (Reader ParserPrefs) ParserPrefs
 -> ExceptT
      ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs)
-> (Reader ParserPrefs ParserPrefs
    -> StateT [Context] (Reader ParserPrefs) ParserPrefs)
-> Reader ParserPrefs ParserPrefs
-> ExceptT
     ParseError (StateT [Context] (Reader ParserPrefs)) ParserPrefs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader ParserPrefs ParserPrefs
-> StateT [Context] (Reader ParserPrefs) ParserPrefs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Reader ParserPrefs ParserPrefs -> P ParserPrefs)
-> Reader ParserPrefs ParserPrefs -> P ParserPrefs
forall a b. (a -> b) -> a -> b
$ Reader ParserPrefs ParserPrefs
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

  missingArgP :: ParseError -> Completer -> P a
missingArgP ParseError
e Completer
_ = ParseError -> P a
forall (m :: * -> *) a. MonadP m => ParseError -> m a
errorP ParseError
e
  exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> P a
exitP IsCmdStart
i ArgPolicy
_ Parser b
p = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> P a)
-> (Maybe a
    -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
-> Maybe a
-> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> (a
    -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
-> Maybe a
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ParseError
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ParseError
 -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
-> (Parser b -> ParseError)
-> Parser b
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsCmdStart -> SomeParser -> ParseError
MissingError IsCmdStart
i (SomeParser -> ParseError)
-> (Parser b -> SomeParser) -> Parser b -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser b -> SomeParser
forall a. Parser a -> SomeParser
SomeParser (Parser b
 -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
-> Parser b
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall a b. (a -> b) -> a -> b
$ Parser b
p) a -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (m :: * -> *) a. Monad m => a -> m a
return
  errorP :: ParseError -> P a
errorP = ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> P a)
-> (ParseError
    -> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
-> ParseError
-> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

hoistMaybe :: MonadPlus m => Maybe a -> m a
hoistMaybe :: Maybe a -> m a
hoistMaybe = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

hoistEither :: MonadP m => Either ParseError a -> m a
hoistEither :: Either ParseError a -> m a
hoistEither = (ParseError -> m a) -> (a -> m a) -> Either ParseError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError -> m a
forall (m :: * -> *) a. MonadP m => ParseError -> m a
errorP a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])
runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])
runP (P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
p) = Reader ParserPrefs (Either ParseError a, [Context])
-> ParserPrefs -> (Either ParseError a, [Context])
forall r a. Reader r a -> r -> a
runReader (Reader ParserPrefs (Either ParseError a, [Context])
 -> ParserPrefs -> (Either ParseError a, [Context]))
-> (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
    -> Reader ParserPrefs (Either ParseError a, [Context]))
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ParserPrefs
-> (Either ParseError a, [Context])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT [Context] (Reader ParserPrefs) (Either ParseError a)
 -> [Context]
 -> Reader ParserPrefs (Either ParseError a, [Context]))
-> [Context]
-> StateT [Context] (Reader ParserPrefs) (Either ParseError a)
-> Reader ParserPrefs (Either ParseError a, [Context])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [Context] (Reader ParserPrefs) (Either ParseError a)
-> [Context] -> Reader ParserPrefs (Either ParseError a, [Context])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT [] (StateT [Context] (Reader ParserPrefs) (Either ParseError a)
 -> Reader ParserPrefs (Either ParseError a, [Context]))
-> (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
    -> StateT [Context] (Reader ParserPrefs) (Either ParseError a))
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> Reader ParserPrefs (Either ParseError a, [Context])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> StateT [Context] (Reader ParserPrefs) (Either ParseError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
 -> ParserPrefs -> (Either ParseError a, [Context]))
-> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
-> ParserPrefs
-> (Either ParseError a, [Context])
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
p

uncons :: [a] -> Maybe (a, [a])
uncons :: [a] -> Maybe (a, [a])
uncons [] = Maybe (a, [a])
forall a. Maybe a
Nothing
uncons (a
x : [a]
xs) = (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
x, [a]
xs)

runReadM :: MonadP m => ReadM a -> String -> m a
runReadM :: ReadM a -> String -> m a
runReadM (ReadM ReaderT String (Except ParseError) a
r) String
s = Either ParseError a -> m a
forall (m :: * -> *) a. MonadP m => Either ParseError a -> m a
hoistEither (Either ParseError a -> m a)
-> (Except ParseError a -> Either ParseError a)
-> Except ParseError a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except ParseError a -> Either ParseError a
forall e a. Except e a -> Either e a
runExcept (Except ParseError a -> m a) -> Except ParseError a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT String (Except ParseError) a
-> String -> Except ParseError a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT String (Except ParseError) a
r String
s

withReadM :: (String -> String) -> ReadM a -> ReadM a
withReadM :: (String -> String) -> ReadM a -> ReadM a
withReadM String -> String
f = ReaderT String (Except ParseError) a -> ReadM a
forall a. ReaderT String (Except ParseError) a -> ReadM a
ReadM (ReaderT String (Except ParseError) a -> ReadM a)
-> (ReadM a -> ReaderT String (Except ParseError) a)
-> ReadM a
-> ReadM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExceptT ParseError Identity a -> ExceptT ParseError Identity a)
-> ReaderT String (Except ParseError) a
-> ReaderT String (Except ParseError) a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((ParseError -> ParseError)
-> ExceptT ParseError Identity a -> ExceptT ParseError Identity a
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept ParseError -> ParseError
f') (ReaderT String (Except ParseError) a
 -> ReaderT String (Except ParseError) a)
-> (ReadM a -> ReaderT String (Except ParseError) a)
-> ReadM a
-> ReaderT String (Except ParseError) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM a -> ReaderT String (Except ParseError) a
forall a. ReadM a -> ReaderT String (Except ParseError) a
unReadM
  where
    f' :: ParseError -> ParseError
f' (ErrorMsg String
err) = String -> ParseError
ErrorMsg (String -> String
f String
err)
    f' ParseError
e = ParseError
e

data ComplResult a
  = ComplParser SomeParser ArgPolicy
  | ComplOption Completer
  | ComplResult a

instance Functor ComplResult where
  fmap :: (a -> b) -> ComplResult a -> ComplResult b
fmap = (a -> b) -> ComplResult a -> ComplResult b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative ComplResult where
  pure :: a -> ComplResult a
pure = a -> ComplResult a
forall a. a -> ComplResult a
ComplResult
  <*> :: ComplResult (a -> b) -> ComplResult a -> ComplResult b
(<*>) = ComplResult (a -> b) -> ComplResult a -> ComplResult b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ComplResult where
  return :: a -> ComplResult a
return = a -> ComplResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ComplResult a
m >>= :: ComplResult a -> (a -> ComplResult b) -> ComplResult b
>>= a -> ComplResult b
f = case ComplResult a
m of
    ComplResult a
r -> a -> ComplResult b
f a
r
    ComplParser SomeParser
p ArgPolicy
a -> SomeParser -> ArgPolicy -> ComplResult b
forall a. SomeParser -> ArgPolicy -> ComplResult a
ComplParser SomeParser
p ArgPolicy
a
    ComplOption Completer
c -> Completer -> ComplResult b
forall a. Completer -> ComplResult a
ComplOption Completer
c

newtype Completion a =
  Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)

instance Functor Completion where
  fmap :: (a -> b) -> Completion a -> Completion b
fmap a -> b
f (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
m) = ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
 -> Completion b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a b. (a -> b) -> a -> b
$ (a -> b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
m

instance Applicative Completion where
  pure :: a -> Completion a
pure a
a = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a b. (a -> b) -> a -> b
$ a -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) (a -> b)
f <*> :: Completion (a -> b) -> Completion a -> Completion b
<*> Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
a = ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
 -> Completion b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) (a -> b)
f ExceptT ParseError (ReaderT ParserPrefs ComplResult) (a -> b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
a

instance Alternative Completion where
  empty :: Completion a
empty = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (f :: * -> *) a. Alternative f => f a
empty
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x <|> :: Completion a -> Completion a -> Completion a
<|> Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y

instance Monad Completion where
  return :: a -> Completion a
return = a -> Completion a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x >>= :: Completion a -> (a -> Completion b) -> Completion b
>>= a -> Completion b
k = ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
 -> Completion b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
-> Completion b
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> (a -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> case a -> Completion b
k a
a of Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
y -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) b
y

instance MonadPlus Completion where
  mzero :: Completion a
mzero = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: Completion a -> Completion a -> Completion a
mplus (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x) (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y) = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y

instance MonadP Completion where
  enterContext :: String -> ParserInfo a -> Completion ()
enterContext String
_ ParserInfo a
_ = () -> Completion ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  exitContext :: Completion ()
exitContext = () -> Completion ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  getPrefs :: Completion ParserPrefs
getPrefs = ExceptT ParseError (ReaderT ParserPrefs ComplResult) ParserPrefs
-> Completion ParserPrefs
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) ParserPrefs
 -> Completion ParserPrefs)
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) ParserPrefs
-> Completion ParserPrefs
forall a b. (a -> b) -> a -> b
$ ReaderT ParserPrefs ComplResult ParserPrefs
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) ParserPrefs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT ParserPrefs ComplResult ParserPrefs
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

  missingArgP :: ParseError -> Completer -> Completion a
missingArgP ParseError
_ = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> (Completer
    -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
-> Completer
-> Completion a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ParserPrefs ComplResult a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ParserPrefs ComplResult a
 -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
-> (Completer -> ReaderT ParserPrefs ComplResult a)
-> Completer
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComplResult a -> ReaderT ParserPrefs ComplResult a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ComplResult a -> ReaderT ParserPrefs ComplResult a)
-> (Completer -> ComplResult a)
-> Completer
-> ReaderT ParserPrefs ComplResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Completer -> ComplResult a
forall a. Completer -> ComplResult a
ComplOption
  exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> Completion a
exitP IsCmdStart
_ ArgPolicy
a Parser b
p Maybe a
_ = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> (ComplResult a
    -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
-> ComplResult a
-> Completion a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ParserPrefs ComplResult a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ParserPrefs ComplResult a
 -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
-> (ComplResult a -> ReaderT ParserPrefs ComplResult a)
-> ComplResult a
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComplResult a -> ReaderT ParserPrefs ComplResult a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ComplResult a -> Completion a) -> ComplResult a -> Completion a
forall a b. (a -> b) -> a -> b
$ SomeParser -> ArgPolicy -> ComplResult a
forall a. SomeParser -> ArgPolicy -> ComplResult a
ComplParser (Parser b -> SomeParser
forall a. Parser a -> SomeParser
SomeParser Parser b
p) ArgPolicy
a
  errorP :: ParseError -> Completion a
errorP = ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
 -> Completion a)
-> (ParseError
    -> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
-> ParseError
-> Completion a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError
-> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

runCompletion :: Completion r -> ParserPrefs -> Maybe (Either (SomeParser, ArgPolicy) Completer)
runCompletion :: Completion r
-> ParserPrefs -> Maybe (Either (SomeParser, ArgPolicy) Completer)
runCompletion (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) r
c) ParserPrefs
prefs = case ReaderT ParserPrefs ComplResult (Either ParseError r)
-> ParserPrefs -> ComplResult (Either ParseError r)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT ParseError (ReaderT ParserPrefs ComplResult) r
-> ReaderT ParserPrefs ComplResult (Either ParseError r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT ParseError (ReaderT ParserPrefs ComplResult) r
c) ParserPrefs
prefs of
  ComplResult Either ParseError r
_ -> Maybe (Either (SomeParser, ArgPolicy) Completer)
forall a. Maybe a
Nothing
  ComplParser SomeParser
p' ArgPolicy
a' -> Either (SomeParser, ArgPolicy) Completer
-> Maybe (Either (SomeParser, ArgPolicy) Completer)
forall a. a -> Maybe a
Just (Either (SomeParser, ArgPolicy) Completer
 -> Maybe (Either (SomeParser, ArgPolicy) Completer))
-> Either (SomeParser, ArgPolicy) Completer
-> Maybe (Either (SomeParser, ArgPolicy) Completer)
forall a b. (a -> b) -> a -> b
$ (SomeParser, ArgPolicy) -> Either (SomeParser, ArgPolicy) Completer
forall a b. a -> Either a b
Left (SomeParser
p', ArgPolicy
a')
  ComplOption Completer
compl -> Either (SomeParser, ArgPolicy) Completer
-> Maybe (Either (SomeParser, ArgPolicy) Completer)
forall a. a -> Maybe a
Just (Either (SomeParser, ArgPolicy) Completer
 -> Maybe (Either (SomeParser, ArgPolicy) Completer))
-> Either (SomeParser, ArgPolicy) Completer
-> Maybe (Either (SomeParser, ArgPolicy) Completer)
forall a b. (a -> b) -> a -> b
$ Completer -> Either (SomeParser, ArgPolicy) Completer
forall a b. b -> Either a b
Right Completer
compl

-- A "ListT done right" implementation

newtype ListT m a = ListT
  { ListT m a -> m (TStep a (ListT m a))
stepListT :: m (TStep a (ListT m a)) }

data TStep a x
  = TNil
  | TCons a x

bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep a -> b
_ x -> y
_ TStep a x
TNil = TStep b y
forall a x. TStep a x
TNil
bimapTStep a -> b
f x -> y
g (TCons a
a x
x) = b -> y -> TStep b y
forall a x. a -> x -> TStep a x
TCons (a -> b
f a
a) (x -> y
g x
x)

hoistList :: Monad m => [a] -> ListT m a
hoistList :: [a] -> ListT m a
hoistList = (a -> ListT m a -> ListT m a) -> ListT m a -> [a] -> ListT m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x ListT m a
xt -> m (TStep a (ListT m a)) -> ListT m a
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (TStep a (ListT m a) -> m (TStep a (ListT m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ListT m a -> TStep a (ListT m a)
forall a x. a -> x -> TStep a x
TCons a
x ListT m a
xt))) ListT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

takeListT :: Monad m => Int -> ListT m a -> ListT m a
takeListT :: Int -> ListT m a -> ListT m a
takeListT Int
0 = ListT m a -> ListT m a -> ListT m a
forall a b. a -> b -> a
const ListT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
takeListT Int
n = m (TStep a (ListT m a)) -> ListT m a
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (m (TStep a (ListT m a)) -> ListT m a)
-> (ListT m a -> m (TStep a (ListT m a))) -> ListT m a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TStep a (ListT m a) -> TStep a (ListT m a))
-> m (TStep a (ListT m a)) -> m (TStep a (ListT m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> a)
-> (ListT m a -> ListT m a)
-> TStep a (ListT m a)
-> TStep a (ListT m a)
forall a b x y. (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep a -> a
forall a. a -> a
id (Int -> ListT m a -> ListT m a
forall (m :: * -> *) a. Monad m => Int -> ListT m a -> ListT m a
takeListT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))) (m (TStep a (ListT m a)) -> m (TStep a (ListT m a)))
-> (ListT m a -> m (TStep a (ListT m a)))
-> ListT m a
-> m (TStep a (ListT m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT

runListT :: Monad m => ListT m a -> m [a]
runListT :: ListT m a -> m [a]
runListT ListT m a
xs = do
  TStep a (ListT m a)
s <- ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT ListT m a
xs
  case TStep a (ListT m a)
s of
    TStep a (ListT m a)
TNil -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    TCons a
x ListT m a
xt -> ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (ListT m a -> m [a]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
runListT ListT m a
xt)

instance Monad m => Functor (ListT m) where
  fmap :: (a -> b) -> ListT m a -> ListT m b
fmap a -> b
f = m (TStep b (ListT m b)) -> ListT m b
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT
         (m (TStep b (ListT m b)) -> ListT m b)
-> (ListT m a -> m (TStep b (ListT m b))) -> ListT m a -> ListT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TStep a (ListT m a) -> TStep b (ListT m b))
-> m (TStep a (ListT m a)) -> m (TStep b (ListT m b))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> b)
-> (ListT m a -> ListT m b)
-> TStep a (ListT m a)
-> TStep b (ListT m b)
forall a b x y. (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep a -> b
f ((a -> b) -> ListT m a -> ListT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f))
         (m (TStep a (ListT m a)) -> m (TStep b (ListT m b)))
-> (ListT m a -> m (TStep a (ListT m a)))
-> ListT m a
-> m (TStep b (ListT m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT

instance Monad m => Applicative (ListT m) where
  pure :: a -> ListT m a
pure = [a] -> ListT m a
forall (m :: * -> *) a. Monad m => [a] -> ListT m a
hoistList ([a] -> ListT m a) -> (a -> [a]) -> a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: ListT m (a -> b) -> ListT m a -> ListT m b
(<*>) = ListT m (a -> b) -> ListT m a -> ListT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (ListT m) where
  return :: a -> ListT m a
return = a -> ListT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ListT m a
xs >>= :: ListT m a -> (a -> ListT m b) -> ListT m b
>>= a -> ListT m b
f = m (TStep b (ListT m b)) -> ListT m b
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (m (TStep b (ListT m b)) -> ListT m b)
-> m (TStep b (ListT m b)) -> ListT m b
forall a b. (a -> b) -> a -> b
$ do
    TStep a (ListT m a)
s <- ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT ListT m a
xs
    case TStep a (ListT m a)
s of
      TStep a (ListT m a)
TNil -> TStep b (ListT m b) -> m (TStep b (ListT m b))
forall (m :: * -> *) a. Monad m => a -> m a
return TStep b (ListT m b)
forall a x. TStep a x
TNil
      TCons a
x ListT m a
xt -> ListT m b -> m (TStep b (ListT m b))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT (ListT m b -> m (TStep b (ListT m b)))
-> ListT m b -> m (TStep b (ListT m b))
forall a b. (a -> b) -> a -> b
$ a -> ListT m b
f a
x ListT m b -> ListT m b -> ListT m b
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (ListT m a
xt ListT m a -> (a -> ListT m b) -> ListT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ListT m b
f)

instance Monad m => Alternative (ListT m) where
  empty :: ListT m a
empty = ListT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: ListT m a -> ListT m a -> ListT m a
(<|>) = ListT m a -> ListT m a -> ListT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadTrans ListT where
  lift :: m a -> ListT m a
lift = m (TStep a (ListT m a)) -> ListT m a
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (m (TStep a (ListT m a)) -> ListT m a)
-> (m a -> m (TStep a (ListT m a))) -> m a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> TStep a (ListT m a)) -> m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a -> ListT m a -> TStep a (ListT m a)
forall a x. a -> x -> TStep a x
`TCons` ListT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)

instance Monad m => MonadPlus (ListT m) where
  mzero :: ListT m a
mzero = m (TStep a (ListT m a)) -> ListT m a
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (TStep a (ListT m a) -> m (TStep a (ListT m a))
forall (m :: * -> *) a. Monad m => a -> m a
return TStep a (ListT m a)
forall a x. TStep a x
TNil)
  mplus :: ListT m a -> ListT m a -> ListT m a
mplus ListT m a
xs ListT m a
ys = m (TStep a (ListT m a)) -> ListT m a
forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (m (TStep a (ListT m a)) -> ListT m a)
-> m (TStep a (ListT m a)) -> ListT m a
forall a b. (a -> b) -> a -> b
$ do
    TStep a (ListT m a)
s <- ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT ListT m a
xs
    case TStep a (ListT m a)
s of
      TStep a (ListT m a)
TNil -> ListT m a -> m (TStep a (ListT m a))
forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT ListT m a
ys
      TCons a
x ListT m a
xt -> TStep a (ListT m a) -> m (TStep a (ListT m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TStep a (ListT m a) -> m (TStep a (ListT m a)))
-> TStep a (ListT m a) -> m (TStep a (ListT m a))
forall a b. (a -> b) -> a -> b
$ a -> ListT m a -> TStep a (ListT m a)
forall a x. a -> x -> TStep a x
TCons a
x (ListT m a
xt ListT m a -> ListT m a -> ListT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ListT m a
ys)

-- nondeterminism monad with cut operator

newtype NondetT m a = NondetT
  { NondetT m a -> ListT (StateT Bool m) a
runNondetT :: ListT (StateT Bool m) a }

instance Monad m => Functor (NondetT m) where
  fmap :: (a -> b) -> NondetT m a -> NondetT m b
fmap a -> b
f = ListT (StateT Bool m) b -> NondetT m b
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) b -> NondetT m b)
-> (NondetT m a -> ListT (StateT Bool m) b)
-> NondetT m a
-> NondetT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ListT (StateT Bool m) a -> ListT (StateT Bool m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ListT (StateT Bool m) a -> ListT (StateT Bool m) b)
-> (NondetT m a -> ListT (StateT Bool m) a)
-> NondetT m a
-> ListT (StateT Bool m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NondetT m a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT

instance Monad m => Applicative (NondetT m) where
  pure :: a -> NondetT m a
pure = ListT (StateT Bool m) a -> NondetT m a
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) a -> NondetT m a)
-> (a -> ListT (StateT Bool m) a) -> a -> NondetT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ListT (StateT Bool m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NondetT ListT (StateT Bool m) (a -> b)
m1 <*> :: NondetT m (a -> b) -> NondetT m a -> NondetT m b
<*> NondetT ListT (StateT Bool m) a
m2 = ListT (StateT Bool m) b -> NondetT m b
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) (a -> b)
m1 ListT (StateT Bool m) (a -> b)
-> ListT (StateT Bool m) a -> ListT (StateT Bool m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ListT (StateT Bool m) a
m2)

instance Monad m => Monad (NondetT m) where
  return :: a -> NondetT m a
return = a -> NondetT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NondetT ListT (StateT Bool m) a
m1 >>= :: NondetT m a -> (a -> NondetT m b) -> NondetT m b
>>= a -> NondetT m b
f = ListT (StateT Bool m) b -> NondetT m b
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) b -> NondetT m b)
-> ListT (StateT Bool m) b -> NondetT m b
forall a b. (a -> b) -> a -> b
$ ListT (StateT Bool m) a
m1 ListT (StateT Bool m) a
-> (a -> ListT (StateT Bool m) b) -> ListT (StateT Bool m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NondetT m b -> ListT (StateT Bool m) b
forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT (NondetT m b -> ListT (StateT Bool m) b)
-> (a -> NondetT m b) -> a -> ListT (StateT Bool m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NondetT m b
f

instance Monad m => MonadPlus (NondetT m) where
  mzero :: NondetT m a
mzero = ListT (StateT Bool m) a -> NondetT m a
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT ListT (StateT Bool m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  NondetT ListT (StateT Bool m) a
m1 mplus :: NondetT m a -> NondetT m a -> NondetT m a
`mplus` NondetT ListT (StateT Bool m) a
m2 = ListT (StateT Bool m) a -> NondetT m a
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) a
m1 ListT (StateT Bool m) a
-> ListT (StateT Bool m) a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ListT (StateT Bool m) a
m2)

instance Monad m => Alternative (NondetT m) where
  empty :: NondetT m a
empty = NondetT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: NondetT m a -> NondetT m a -> NondetT m a
(<|>) = NondetT m a -> NondetT m a -> NondetT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadTrans NondetT where
  lift :: m a -> NondetT m a
lift = ListT (StateT Bool m) a -> NondetT m a
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) a -> NondetT m a)
-> (m a -> ListT (StateT Bool m) a) -> m a -> NondetT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT Bool m a -> ListT (StateT Bool m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT Bool m a -> ListT (StateT Bool m) a)
-> (m a -> StateT Bool m a) -> m a -> ListT (StateT Bool m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT Bool m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

(<!>) :: Monad m => NondetT m a -> NondetT m a -> NondetT m a
<!> :: NondetT m a -> NondetT m a -> NondetT m a
(<!>) NondetT m a
m1 NondetT m a
m2 = ListT (StateT Bool m) a -> NondetT m a
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) a -> NondetT m a)
-> (ListT (StateT Bool m) a -> ListT (StateT Bool m) a)
-> ListT (StateT Bool m) a
-> NondetT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT (StateT Bool m) a
-> ListT (StateT Bool m) a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (NondetT m a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT NondetT m a
m1) (ListT (StateT Bool m) a -> NondetT m a)
-> ListT (StateT Bool m) a -> NondetT m a
forall a b. (a -> b) -> a -> b
$ do
  Bool
s <- StateT Bool m Bool -> ListT (StateT Bool m) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT Bool m Bool
forall (m :: * -> *) s. Monad m => StateT s m s
get
  Bool -> ListT (StateT Bool m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
s)
  NondetT m a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT NondetT m a
m2

cut :: Monad m => NondetT m ()
cut :: NondetT m ()
cut = ListT (StateT Bool m) () -> NondetT m ()
forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) () -> NondetT m ())
-> ListT (StateT Bool m) () -> NondetT m ()
forall a b. (a -> b) -> a -> b
$ StateT Bool m () -> ListT (StateT Bool m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool -> StateT Bool m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
True)

disamb :: Monad m => Bool -> NondetT m a -> m (Maybe a)
disamb :: Bool -> NondetT m a -> m (Maybe a)
disamb Bool
allow_amb NondetT m a
xs = do
  [a]
xs' <- (StateT Bool m [a] -> Bool -> m [a]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Bool
False)
       (StateT Bool m [a] -> m [a])
-> (NondetT m a -> StateT Bool m [a]) -> NondetT m a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT (StateT Bool m) a -> StateT Bool m [a]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
runListT
       (ListT (StateT Bool m) a -> StateT Bool m [a])
-> (NondetT m a -> ListT (StateT Bool m) a)
-> NondetT m a
-> StateT Bool m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ListT (StateT Bool m) a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. Monad m => Int -> ListT m a -> ListT m a
takeListT (if Bool
allow_amb then Int
1 else Int
2)
       (ListT (StateT Bool m) a -> ListT (StateT Bool m) a)
-> (NondetT m a -> ListT (StateT Bool m) a)
-> NondetT m a
-> ListT (StateT Bool m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NondetT m a -> ListT (StateT Bool m) a
forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT (NondetT m a -> m [a]) -> NondetT m a -> m [a]
forall a b. (a -> b) -> a -> b
$ NondetT m a
xs
  Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ case [a]
xs' of
    [a
x] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    [a]
_   -> Maybe a
forall a. Maybe a
Nothing