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 :: forall a b. (a -> b) -> P a -> P b
fmap a -> b
f (P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
m) = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> 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 :: forall a. a -> P a
pure a
a = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) (a -> b)
f <*> :: forall a b. P (a -> b) -> P a -> P b
<*> P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
a = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) (a -> b)
f 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 :: forall a. P a
empty = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall (f :: * -> *) a. Alternative f => f a
empty
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x <|> :: forall a. P a -> P a -> P a
<|> P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
y

instance Monad P where
  return :: forall a. a -> P a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  P ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
k = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a
x 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 :: forall a. P a
mzero = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: forall a. 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) = forall a.
ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a -> P a
P forall a b. (a -> b) -> a -> b
$ 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  forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Context -> String
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Context]
ns

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

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

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

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

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

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

runReadM :: MonadP m => ReadM a -> String -> m a
runReadM :: forall (m :: * -> *) a. MonadP m => ReadM a -> String -> m a
runReadM (ReadM ReaderT String (Except ParseError) a
r) String
s = forall (m :: * -> *) a. MonadP m => Either ParseError a -> m a
hoistEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Except e a -> Either e a
runExcept forall a b. (a -> b) -> a -> b
$ 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 :: forall a. (String -> String) -> ReadM a -> ReadM a
withReadM String -> String
f = forall a. ReaderT String (Except ParseError) a -> ReadM a
ReadM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept ParseError -> ParseError
f') forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a b. (a -> b) -> ComplResult a -> ComplResult b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative ComplResult where
  pure :: forall a. a -> ComplResult a
pure = forall a. a -> ComplResult a
ComplResult
  <*> :: forall a 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 :: forall a. a -> ComplResult a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ComplResult a
m >>= :: forall a b. 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 -> forall a. SomeParser -> ArgPolicy -> ComplResult a
ComplParser SomeParser
p ArgPolicy
a
    ComplOption Completer
c -> forall a. Completer -> ComplResult a
ComplOption Completer
c

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

instance Functor Completion where
  fmap :: forall a b. (a -> b) -> Completion a -> Completion b
fmap a -> b
f (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
m) = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> 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 :: forall a. a -> Completion a
pure a
a = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) (a -> b)
f <*> :: forall a b. Completion (a -> b) -> Completion a -> Completion b
<*> Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
a = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) (a -> b)
f 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 :: forall a. Completion a
empty = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall (f :: * -> *) a. Alternative f => f a
empty
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x <|> :: forall a. Completion a -> Completion a -> Completion a
<|> Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y

instance Monad Completion where
  return :: forall a. a -> Completion a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x >>= :: forall a b. Completion a -> (a -> Completion b) -> Completion b
>>= a -> Completion b
k = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x 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 :: forall a. Completion a
mzero = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: forall a. Completion a -> Completion a -> Completion a
mplus (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
x) (Completion ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
y) = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ 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 :: forall a. String -> ParserInfo a -> Completion ()
enterContext String
_ ParserInfo a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  exitContext :: Completion ()
exitContext = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  getPrefs :: Completion ParserPrefs
getPrefs = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

  missingArgP :: forall a. ParseError -> Completer -> Completion a
missingArgP ParseError
_ = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Completer -> ComplResult a
ComplOption
  exitP :: forall b a.
IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> Completion a
exitP IsCmdStart
_ ArgPolicy
a Parser b
p Maybe a
_ = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion 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 a. SomeParser -> ArgPolicy -> ComplResult a
ComplParser (forall a. Parser a -> SomeParser
SomeParser Parser b
p) ArgPolicy
a
  errorP :: forall a. ParseError -> Completion a
errorP = forall a.
ExceptT ParseError (ReaderT ParserPrefs ComplResult) a
-> Completion a
Completion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

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

-- A "ListT done right" implementation

newtype ListT m a = ListT
  { forall (m :: * -> *) a. 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 :: forall a b x y. (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep a -> b
_ x -> y
_ TStep a x
TNil = forall a x. TStep a x
TNil
bimapTStep a -> b
f x -> y
g (TCons a
a x
x) = 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 :: forall (m :: * -> *) a. Monad m => [a] -> ListT m a
hoistList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x ListT m a
xt -> forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a x. a -> x -> TStep a x
TCons a
x ListT m a
xt))) forall (m :: * -> *) a. MonadPlus m => m a
mzero

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

runListT :: Monad m => ListT m a -> m [a]
runListT :: forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
runListT ListT m a
xs = do
  TStep a (ListT m a)
s <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    TCons a
x ListT m a
xt -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
x forall a. a -> [a] -> [a]
:) (forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
runListT ListT m a
xt)

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

instance Monad m => Applicative (ListT m) where
  pure :: forall a. a -> ListT m a
pure = forall (m :: * -> *) a. Monad m => [a] -> ListT m a
hoistList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a 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 :: forall a. a -> ListT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ListT m a
xs >>= :: forall a b. ListT m a -> (a -> ListT m b) -> ListT m b
>>= a -> ListT m b
f = forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ do
    TStep a (ListT m a)
s <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a x. TStep a x
TNil
      TCons a
x ListT m a
xt -> forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT forall a b. (a -> b) -> a -> b
$ a -> ListT m b
f a
x forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (ListT m a
xt 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 :: forall a. ListT m a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall 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 :: forall (m :: * -> *) a. Monad m => m a -> ListT m a
lift = forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a x. a -> x -> TStep a x
`TCons` forall (m :: * -> *) a. MonadPlus m => m a
mzero)

instance Monad m => MonadPlus (ListT m) where
  mzero :: forall a. ListT m a
mzero = forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT (forall (m :: * -> *) a. Monad m => a -> m a
return forall a x. TStep a x
TNil)
  mplus :: forall a. ListT m a -> ListT m a -> ListT m a
mplus ListT m a
xs ListT m a
ys = forall (m :: * -> *) a. m (TStep a (ListT m a)) -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ do
    TStep a (ListT m a)
s <- 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 -> forall (m :: * -> *) a. ListT m a -> m (TStep a (ListT m a))
stepListT ListT m a
ys
      TCons a
x ListT m a
xt -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a x. a -> x -> TStep a x
TCons a
x (ListT m a
xt 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
  { forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT :: ListT (StateT Bool m) a }

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

instance Monad m => Applicative (NondetT m) where
  pure :: forall a. a -> NondetT m a
pure = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NondetT ListT (StateT Bool m) (a -> b)
m1 <*> :: forall a b. NondetT m (a -> b) -> NondetT m a -> NondetT m b
<*> NondetT ListT (StateT Bool m) a
m2 = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) (a -> b)
m1 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 :: forall a. a -> NondetT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NondetT ListT (StateT Bool m) a
m1 >>= :: forall a b. NondetT m a -> (a -> NondetT m b) -> NondetT m b
>>= a -> NondetT m b
f = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT forall a b. (a -> b) -> a -> b
$ ListT (StateT Bool m) a
m1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. NondetT m a -> ListT (StateT Bool m) a
runNondetT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NondetT m b
f

instance Monad m => MonadPlus (NondetT m) where
  mzero :: forall a. NondetT m a
mzero = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT forall (m :: * -> *) a. MonadPlus m => m a
mzero
  NondetT ListT (StateT Bool m) a
m1 mplus :: forall a. NondetT m a -> NondetT m a -> NondetT m a
`mplus` NondetT ListT (StateT Bool m) a
m2 = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT (ListT (StateT Bool m) a
m1 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 :: forall a. NondetT m a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall 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 :: forall (m :: * -> *) a. Monad m => m a -> NondetT m a
lift = forall (m :: * -> *) a. ListT (StateT Bool m) a -> NondetT m a
NondetT 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

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

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

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