{-# 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
{
forall (m :: * -> *). SimulationState m -> Text
precedingPrompt :: Text,
forall (m :: * -> *). SimulationState m -> SimulationFunction m
simulationFunction :: SimulationFunction m,
forall (m :: * -> *). SimulationState m -> [CompletionFunc IO]
completionFunctions :: [CompletionFunc IO]
}
newtype BylineT m a = BylineT
{forall (m :: * -> *) a.
BylineT m a -> MaybeT (StateT (SimulationState m) m) a
unBylineT :: MaybeT (StateT (SimulationState m) m) a}
deriving newtype
( 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
<$ :: forall a b. a -> BylineT m b -> BylineT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> BylineT m b -> BylineT m a
fmap :: forall a b. (a -> b) -> BylineT m a -> BylineT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> BylineT m a -> BylineT m b
Functor,
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
<* :: forall a b. 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
*> :: forall a b. 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 :: forall a b c.
(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
<*> :: forall a b. 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 :: forall a. a -> BylineT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> BylineT m a
Applicative,
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 :: forall a. a -> BylineT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> BylineT m a
>> :: forall a b. 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
>>= :: forall a 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
Monad,
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 :: forall a. IO a -> BylineT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> BylineT m a
MonadIO,
MonadReader r,
MonadError e,
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 :: forall a b. ((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
MonadCont,
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 :: forall e a. Exception e => e -> BylineT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> BylineT m a
MonadThrow,
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 :: forall e a.
Exception e =>
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
MonadCatch
)
instance MonadState s m => MonadState s (BylineT m) where
state :: forall a. (s -> (a, s)) -> BylineT m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
instance MonadTrans BylineT where
lift :: forall (m :: * -> *) a. Monad m => m a -> BylineT m a
lift = forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT 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
instance Monad m => MonadByline (BylineT m) where
liftByline :: forall a. F PrimF a -> BylineT m a
liftByline = 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 :: forall (m :: * -> *) a. Monad m => F PrimF a -> BylineT m a
evalPrimF = 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 -> forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s forall a b. (a -> b) -> a -> b
$ \Text
t ->
if Text -> Bool
Text.null Text
t
then Text -> BylineT m a
k (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 -> forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s forall a b. (a -> b) -> a -> b
$ \Text
t ->
if Text -> Bool
Text.null Text
t
then forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT 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 -> 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 ->
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT
( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SimulationState m
st ->
SimulationState m
st {completionFunctions :: [CompletionFunc IO]
completionFunctions = CompletionFunc IO
f forall a. a -> [a] -> [a]
: forall (m :: * -> *). SimulationState m -> [CompletionFunc IO]
completionFunctions SimulationState m
st}
)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BylineT m a
k
PopCompFunc BylineT m a
k ->
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT
( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SimulationState m
st ->
case 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}
)
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 :: forall b. Stylized Text -> (Text -> BylineT m b) -> BylineT m b
simulate Stylized Text
s Text -> BylineT m b
f = do
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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 <- forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). SimulationState m -> SimulationFunction m
simulationFunction)
forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SimulationFunction m
simfun) 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 -> forall (m :: * -> *) a.
MaybeT (StateT (SimulationState m) m) a -> BylineT m a
BylineT forall (f :: * -> *) a. Alternative f => f a
empty
runBylineT :: Monad m => SimulationFunction m -> BylineT m a -> m (Maybe a)
runBylineT :: forall (m :: * -> *) a.
Monad m =>
SimulationFunction m -> BylineT m a -> m (Maybe a)
runBylineT SimulationFunction m
f =
forall (m :: * -> *) a.
BylineT m a -> MaybeT (StateT (SimulationState m) m) a
unBylineT
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall (m :: * -> *).
Text
-> SimulationFunction m -> [CompletionFunc IO] -> SimulationState m
SimulationState Text
"" SimulationFunction m
f [])