{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK hide #-}
module Byline.Internal.Simulation
( Simulated (..),
SimulationFunction,
SimulationState (..),
BylineT (..),
runBylineT,
)
where
import Byline.Internal.Completion
import Byline.Internal.Eval (MonadByline (..))
import Byline.Internal.Prim
import Byline.Internal.Stylized
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Cont (MonadCont)
import Control.Monad.Except (MonadError)
import qualified Control.Monad.Trans.Free.Church as Free
import qualified Data.Text as Text
data Simulated
=
SimulatedInput Text
|
SimulatedEOF
type SimulationFunction m = StateT (SimulationState m) m Simulated
data SimulationState m = SimulationState
{
SimulationState m -> Text
precedingPrompt :: Text,
SimulationState m -> SimulationFunction m
simulationFunction :: SimulationFunction m,
SimulationState m -> [CompletionFunc IO]
completionFunctions :: [CompletionFunc IO]
}
newtype BylineT m a = BylineT
{BylineT m a -> MaybeT (StateT (SimulationState m) m) a
unBylineT :: MaybeT (StateT (SimulationState m) m) a}
deriving newtype
( a -> BylineT m b -> BylineT m a
(a -> b) -> BylineT m a -> BylineT m b
(forall a b. (a -> b) -> BylineT m a -> BylineT m b)
-> (forall a b. a -> BylineT m b -> BylineT m a)
-> Functor (BylineT m)
forall a b. a -> BylineT m b -> BylineT m a
forall a b. (a -> b) -> BylineT m a -> BylineT m b
forall (m :: * -> *) a b.
Functor m =>
a -> BylineT m b -> BylineT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> BylineT m a -> BylineT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BylineT m b -> BylineT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> BylineT m b -> BylineT m a
fmap :: (a -> b) -> BylineT m a -> BylineT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> BylineT m a -> BylineT m b
Functor,
Functor (BylineT m)
a -> BylineT m a
Functor (BylineT m)
-> (forall a. a -> BylineT m a)
-> (forall a b. BylineT m (a -> b) -> BylineT m a -> BylineT m b)
-> (forall a b c.
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m b)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m a)
-> Applicative (BylineT m)
BylineT m a -> BylineT m b -> BylineT m b
BylineT m a -> BylineT m b -> BylineT m a
BylineT m (a -> b) -> BylineT m a -> BylineT m b
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
forall a. a -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m b
forall a b. BylineT m (a -> b) -> BylineT m a -> BylineT m b
forall a b c.
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
forall (m :: * -> *). Monad m => Functor (BylineT m)
forall (m :: * -> *) a. Monad m => a -> BylineT m a
forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m a
forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m b
forall (m :: * -> *) a b.
Monad m =>
BylineT m (a -> b) -> BylineT m a -> BylineT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: BylineT m a -> BylineT m b -> BylineT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m a
*> :: BylineT m a -> BylineT m b -> BylineT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m b
liftA2 :: (a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
<*> :: BylineT m (a -> b) -> BylineT m a -> BylineT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
BylineT m (a -> b) -> BylineT m a -> BylineT m b
pure :: a -> BylineT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> BylineT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (BylineT m)
Applicative,
Applicative (BylineT m)
a -> BylineT m a
Applicative (BylineT m)
-> (forall a b. BylineT m a -> (a -> BylineT m b) -> BylineT m b)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m b)
-> (forall a. a -> BylineT m a)
-> Monad (BylineT m)
BylineT m a -> (a -> BylineT m b) -> BylineT m b
BylineT m a -> BylineT m b -> BylineT m b
forall a. a -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m b
forall a b. BylineT m a -> (a -> BylineT m b) -> BylineT m b
forall (m :: * -> *). Monad m => Applicative (BylineT m)
forall (m :: * -> *) a. Monad m => a -> BylineT m a
forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m b
forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> (a -> BylineT m b) -> BylineT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> BylineT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> BylineT m a
>> :: BylineT m a -> BylineT m b -> BylineT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> BylineT m b -> BylineT m b
>>= :: BylineT m a -> (a -> BylineT m b) -> BylineT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
BylineT m a -> (a -> BylineT m b) -> BylineT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (BylineT m)
Monad,
Monad (BylineT m)
Monad (BylineT m)
-> (forall a. IO a -> BylineT m a) -> MonadIO (BylineT m)
IO a -> BylineT m a
forall a. IO a -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (BylineT m)
forall (m :: * -> *) a. MonadIO m => IO a -> BylineT m a
liftIO :: IO a -> BylineT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> BylineT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (BylineT m)
MonadIO,
MonadReader r,
MonadError e,
Monad (BylineT m)
Monad (BylineT m)
-> (forall a b. ((a -> BylineT m b) -> BylineT m a) -> BylineT m a)
-> MonadCont (BylineT m)
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
forall a b. ((a -> BylineT m b) -> BylineT m a) -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall (m :: * -> *). MonadCont m => Monad (BylineT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
callCC :: ((a -> BylineT m b) -> BylineT m a) -> BylineT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
$cp1MonadCont :: forall (m :: * -> *). MonadCont m => Monad (BylineT m)
MonadCont,
Monad (BylineT m)
e -> BylineT m a
Monad (BylineT m)
-> (forall e a. Exception e => e -> BylineT m a)
-> MonadThrow (BylineT m)
forall e a. Exception e => e -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (BylineT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> BylineT m a
throwM :: e -> BylineT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> BylineT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (BylineT m)
MonadThrow,
MonadThrow (BylineT m)
MonadThrow (BylineT m)
-> (forall e a.
Exception e =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a)
-> MonadCatch (BylineT m)
BylineT m a -> (e -> BylineT m a) -> BylineT m a
forall e a.
Exception e =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (BylineT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
catch :: BylineT m a -> (e -> BylineT m a) -> BylineT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (BylineT m)
MonadCatch
)
instance MonadState s m => MonadState s (BylineT m) where
state :: (s -> (a, s)) -> BylineT m a
state = m a -> BylineT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> BylineT m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> BylineT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
instance MonadTrans BylineT where
lift :: m a -> BylineT m a
lift = MaybeT (StateT (SimulationState m) m) a -> BylineT m a
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT (MaybeT (StateT (SimulationState m) m) a -> BylineT m a)
-> (m a -> MaybeT (StateT (SimulationState m) m) a)
-> m a
-> BylineT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (SimulationState m) m a
-> MaybeT (StateT (SimulationState m) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (SimulationState m) m a
-> MaybeT (StateT (SimulationState m) m) a)
-> (m a -> StateT (SimulationState m) m a)
-> m a
-> MaybeT (StateT (SimulationState m) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT (SimulationState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance Monad m => MonadByline (BylineT m) where
liftByline :: F PrimF a -> BylineT m a
liftByline = F PrimF a -> BylineT m a
forall (m :: * -> *) a. Monad m => F PrimF a -> BylineT m a
evalPrimF
evalPrimF :: forall m a. Monad m => Free.F PrimF a -> BylineT m a
evalPrimF :: F PrimF a -> BylineT m a
evalPrimF = (PrimF (BylineT m a) -> BylineT m a) -> F PrimF a -> BylineT m a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> F f a -> m a
Free.iterM PrimF (BylineT m a) -> BylineT m a
go
where
go :: PrimF (BylineT m a) -> BylineT m a
go :: PrimF (BylineT m a) -> BylineT m a
go = \case
Say Stylized Text
_ BylineT m a
k -> BylineT m a
k
AskLn Stylized Text
s Maybe Text
d Text -> BylineT m a
k -> Stylized Text -> (Text -> BylineT m a) -> BylineT m a
forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s ((Text -> BylineT m a) -> BylineT m a)
-> (Text -> BylineT m a) -> BylineT m a
forall a b. (a -> b) -> a -> b
$ \Text
t ->
if Text -> Bool
Text.null Text
t
then Text -> BylineT m a
k (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t Maybe Text
d)
else Text -> BylineT m a
k Text
t
AskChar Stylized Text
s Char -> BylineT m a
k -> Stylized Text -> (Text -> BylineT m a) -> BylineT m a
forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s ((Text -> BylineT m a) -> BylineT m a)
-> (Text -> BylineT m a) -> BylineT m a
forall a b. (a -> b) -> a -> b
$ \Text
t ->
if Text -> Bool
Text.null Text
t
then MaybeT (StateT (SimulationState m) m) a -> BylineT m a
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT MaybeT (StateT (SimulationState m) m) a
forall (f :: * -> *) a. Alternative f => f a
empty
else Char -> BylineT m a
k (Text -> Char
Text.head Text
t)
AskPassword Stylized Text
s Maybe Char
_ Text -> BylineT m a
k -> Stylized Text -> (Text -> BylineT m a) -> BylineT m a
forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s Text -> BylineT m a
k
PushCompFunc CompletionFunc IO
f BylineT m a
k ->
MaybeT (StateT (SimulationState m) m) () -> BylineT m ()
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT
( StateT (SimulationState m) m ()
-> MaybeT (StateT (SimulationState m) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (SimulationState m) m ()
-> MaybeT (StateT (SimulationState m) m) ())
-> ((SimulationState m -> SimulationState m)
-> StateT (SimulationState m) m ())
-> (SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimulationState m -> SimulationState m)
-> StateT (SimulationState m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ())
-> (SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall a b. (a -> b) -> a -> b
$ \SimulationState m
st ->
SimulationState m
st {completionFunctions :: [CompletionFunc IO]
completionFunctions = CompletionFunc IO
f CompletionFunc IO -> [CompletionFunc IO] -> [CompletionFunc IO]
forall a. a -> [a] -> [a]
: SimulationState m -> [CompletionFunc IO]
forall (m :: * -> *). SimulationState m -> [CompletionFunc IO]
completionFunctions SimulationState m
st}
)
BylineT m () -> BylineT m a -> BylineT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BylineT m a
k
PopCompFunc BylineT m a
k ->
MaybeT (StateT (SimulationState m) m) () -> BylineT m ()
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT
( StateT (SimulationState m) m ()
-> MaybeT (StateT (SimulationState m) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (SimulationState m) m ()
-> MaybeT (StateT (SimulationState m) m) ())
-> ((SimulationState m -> SimulationState m)
-> StateT (SimulationState m) m ())
-> (SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimulationState m -> SimulationState m)
-> StateT (SimulationState m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ())
-> (SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall a b. (a -> b) -> a -> b
$ \SimulationState m
st ->
case SimulationState m -> [CompletionFunc IO]
forall (m :: * -> *). SimulationState m -> [CompletionFunc IO]
completionFunctions SimulationState m
st of
[] -> SimulationState m
st {completionFunctions :: [CompletionFunc IO]
completionFunctions = []}
CompletionFunc IO
_ : [CompletionFunc IO]
xs -> SimulationState m
st {completionFunctions :: [CompletionFunc IO]
completionFunctions = [CompletionFunc IO]
xs}
)
BylineT m () -> BylineT m a -> BylineT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BylineT m a
k
simulate :: Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate :: Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s Text -> BylineT m b
f = do
MaybeT (StateT (SimulationState m) m) () -> BylineT m ()
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT ((SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ())
-> (SimulationState m -> SimulationState m)
-> MaybeT (StateT (SimulationState m) m) ()
forall a b. (a -> b) -> a -> b
$ \SimulationState m
st -> SimulationState m
st {precedingPrompt :: Text
precedingPrompt = RenderMode -> Stylized Text -> Text
renderText RenderMode
Plain Stylized Text
s})
SimulationFunction m
simfun <- MaybeT (StateT (SimulationState m) m) (SimulationFunction m)
-> BylineT m (SimulationFunction m)
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT ((SimulationState m -> SimulationFunction m)
-> MaybeT (StateT (SimulationState m) m) (SimulationFunction m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SimulationState m -> SimulationFunction m
forall (m :: * -> *). SimulationState m -> SimulationFunction m
simulationFunction)
MaybeT (StateT (SimulationState m) m) Simulated
-> BylineT m Simulated
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT (SimulationFunction m
-> MaybeT (StateT (SimulationState m) m) Simulated
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SimulationFunction m
simfun) BylineT m Simulated -> (Simulated -> BylineT m b) -> BylineT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
SimulatedInput Text
t -> Text -> BylineT m b
f Text
t
Simulated
SimulatedEOF -> MaybeT (StateT (SimulationState m) m) b -> BylineT m b
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT MaybeT (StateT (SimulationState m) m) b
forall (f :: * -> *) a. Alternative f => f a
empty
runBylineT :: Monad m => SimulationFunction m -> BylineT m a -> m (Maybe a)
runBylineT :: SimulationFunction m -> BylineT m a -> m (Maybe a)
runBylineT SimulationFunction m
f =
BylineT m a -> MaybeT (StateT (SimulationState m) m) a
forall (m :: * -> *) a.
BylineT m a -> MaybeT (StateT (SimulationState m) m) a
unBylineT
(BylineT m a -> MaybeT (StateT (SimulationState m) m) a)
-> (MaybeT (StateT (SimulationState m) m) a -> m (Maybe a))
-> BylineT m a
-> m (Maybe a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MaybeT (StateT (SimulationState m) m) a
-> StateT (SimulationState m) m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
(MaybeT (StateT (SimulationState m) m) a
-> StateT (SimulationState m) m (Maybe a))
-> (StateT (SimulationState m) m (Maybe a) -> m (Maybe a))
-> MaybeT (StateT (SimulationState m) m) a
-> m (Maybe a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (StateT (SimulationState m) m (Maybe a)
-> SimulationState m -> m (Maybe a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Text
-> SimulationFunction m -> [CompletionFunc IO] -> SimulationState m
forall (m :: * -> *).
Text
-> SimulationFunction m -> [CompletionFunc IO] -> SimulationState m
SimulationState Text
"" SimulationFunction m
f [])