{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK hide #-}

-- |
--
-- Copyright:
--   This file is part of the package byline. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/byline
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the
--   terms contained in the LICENSE file.
--
-- License: BSD-2-Clause
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

-- | Simulated user input.
--
-- @since 1.0.0.0
data Simulated
  = -- | Simulate user input by providing the 'Text' value
    -- they typed as a response to a prompt.
    --
    -- If the asking function wants a single character of input then
    -- only the first character of the provided 'Text' is used.  In
    -- this case, if an empty 'Text' value is given, it will be treated
    -- as an end-of-file (EOF) character.
    SimulatedInput Text
  | -- | Simulate an end-of-file (EOF) character.  Usually this occurs
    -- when the user enters @Control-D@ or when standard input is
    -- exhausted.
    SimulatedEOF

-- | A function that simulates user input by returning a 'Simulated'
-- value.
--
-- The function has full access to the 'SimulationState' including the
-- ability to change the simulation function itself.  For example,
-- below is a function that will return the text \"Current" the first
-- time it is called and \"Next" every time after that.
--
-- @
--
--  textThenDefault :: Monad m => SimulationFunction m
--  textThenDefault = do
--    -- The next input request will come from this function:
--    modify (\s -> s {simulationFunction = pure (SimulatedInput \"Next")})
--
--    -- But this time we'll return different text:
--    pure (SimulatedInput \"Current")
-- @
--
-- @since 1.0.0.0
type SimulationFunction m = StateT (SimulationState m) m Simulated

-- | Stateful information available to the simulation function.
--
-- @since 1.0.0.0
data SimulationState m = SimulationState
  { -- | The prompt associated with current request for input.  This
    -- 'Text' value will /not/ contain any formatting escape codes such
    -- as colors.
    forall (m :: * -> *). SimulationState m -> Text
precedingPrompt :: Text,
    -- | The function that will be called to simulate user input.
    forall (m :: * -> *). SimulationState m -> SimulationFunction m
simulationFunction :: SimulationFunction m,
    -- | The stack of completion functions.
    forall (m :: * -> *). SimulationState m -> [CompletionFunc IO]
completionFunctions :: [CompletionFunc IO]
  }

-- | A monad transformer that implements the 'MonadByline' class
-- without actually doing anything.
--
-- @since 1.0.0.0
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

-- | Evaluate a 'PrimF' instruction.
--
-- @since 1.0.0.0
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

-- | Discharge the 'MonadByline' effect using the given 'SimulationFunction'.
--
-- @since 1.0.0.0
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 [])