module Reflex.Test.Monad.Host
( TestGuestT
, TestGuestConstraints
, ReflexTriggerRef
, MonadReflexTest(..)
, AppState(..)
, ReflexTestT(..)
, runReflexTestT
, ReflexTestApp(..)
, runReflexTestApp
)
where
import Prelude
import Control.Concurrent.Chan
import Control.Monad.IO.Class
import Control.Monad.Fix
import Control.Monad.Primitive
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.State.Strict
import Data.Dependent.Sum
import Data.Functor.Identity
import Data.Kind
import Reflex
import Reflex.Class ()
import Reflex.Host.Class
type TestGuestT t (m :: Type -> Type)
= TriggerEventT t (PostBuildT t (PerformEventT t m))
type TestGuestConstraints t (m :: Type -> Type)
= ( MonadReflexHost t m
, MonadHold t m
, MonadSample t m
, Ref m ~ Ref IO
, MonadRef m
, MonadRef (HostFrame t)
, Ref (HostFrame t) ~ Ref IO
, MonadIO (HostFrame t)
, PrimMonad (HostFrame t)
, MonadIO m
, MonadFix m
)
type ReflexTriggerRef t (m :: Type -> Type) a = Ref m (Maybe (EventTrigger t a))
class MonadReflexTest t m | m -> t where
type InputTriggerRefs m :: Type
type OutputEvents m :: Type
type InnerMonad m :: Type -> Type
inputTriggerRefs :: m (InputTriggerRefs m)
queueEventTrigger :: DSum (EventTrigger t) Identity -> m ()
queueEventTriggerRef :: Ref (InnerMonad m) (Maybe (EventTrigger t a)) -> a -> m ()
outputs :: m (OutputEvents m)
fireQueuedEventsAndRead :: ReadPhase (InnerMonad m) a -> m [a]
fireQueuedEvents :: (Monad (ReadPhase (InnerMonad m))) => m [()]
fireQueuedEvents = forall t (m :: * -> *) a.
MonadReflexTest t m =>
ReadPhase (InnerMonad m) a -> m [a]
fireQueuedEventsAndRead (forall (m :: * -> *) a. Monad m => a -> m a
return ())
data AppState t m = AppState
{ forall t (m :: * -> *).
AppState t m -> [DSum (EventTrigger t) Identity]
_appState_queuedEvents :: [DSum (EventTrigger t) Identity]
, forall t (m :: * -> *). AppState t m -> FireCommand t m
_appState_fire :: FireCommand t m
}
newtype ReflexTestT t intref out m a = ReflexTestT { forall t intref out (m :: * -> *) a.
ReflexTestT t intref out m a
-> ReaderT (intref, out) (StateT (AppState t m) m) a
unReflexTestM :: ReaderT (intref, out) (StateT (AppState t m) m) a }
deriving
( forall a b.
a -> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
forall a b.
(a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
forall t intref out (m :: * -> *) a b.
Functor m =>
a -> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
forall t intref out (m :: * -> *) a b.
Functor m =>
(a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out 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 -> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
$c<$ :: forall t intref out (m :: * -> *) a b.
Functor m =>
a -> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
fmap :: forall a b.
(a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
$cfmap :: forall t intref out (m :: * -> *) a b.
Functor m =>
(a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
Functor
, forall a. a -> ReflexTestT t intref out m a
forall a b.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
forall a b.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
forall a b.
ReflexTestT t intref out m (a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
forall a b c.
(a -> b -> c)
-> ReflexTestT t intref out m a
-> ReflexTestT t intref out m b
-> ReflexTestT t intref out m c
forall {t} {intref} {out} {m :: * -> *}.
Monad m =>
Functor (ReflexTestT t intref out m)
forall t intref out (m :: * -> *) a.
Monad m =>
a -> ReflexTestT t intref out m a
forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m (a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
forall t intref out (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ReflexTestT t intref out m a
-> ReflexTestT t intref out m b
-> ReflexTestT t intref out 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.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
$c<* :: forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m a
*> :: forall a b.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
$c*> :: forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
liftA2 :: forall a b c.
(a -> b -> c)
-> ReflexTestT t intref out m a
-> ReflexTestT t intref out m b
-> ReflexTestT t intref out m c
$cliftA2 :: forall t intref out (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ReflexTestT t intref out m a
-> ReflexTestT t intref out m b
-> ReflexTestT t intref out m c
<*> :: forall a b.
ReflexTestT t intref out m (a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
$c<*> :: forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m (a -> b)
-> ReflexTestT t intref out m a -> ReflexTestT t intref out m b
pure :: forall a. a -> ReflexTestT t intref out m a
$cpure :: forall t intref out (m :: * -> *) a.
Monad m =>
a -> ReflexTestT t intref out m a
Applicative
, forall a. a -> ReflexTestT t intref out m a
forall a b.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
forall a b.
ReflexTestT t intref out m a
-> (a -> ReflexTestT t intref out m b)
-> ReflexTestT t intref out m b
forall t intref out (m :: * -> *).
Monad m =>
Applicative (ReflexTestT t intref out m)
forall t intref out (m :: * -> *) a.
Monad m =>
a -> ReflexTestT t intref out m a
forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> (a -> ReflexTestT t intref out m b)
-> ReflexTestT t intref out 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 -> ReflexTestT t intref out m a
$creturn :: forall t intref out (m :: * -> *) a.
Monad m =>
a -> ReflexTestT t intref out m a
>> :: forall a b.
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
$c>> :: forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> ReflexTestT t intref out m b -> ReflexTestT t intref out m b
>>= :: forall a b.
ReflexTestT t intref out m a
-> (a -> ReflexTestT t intref out m b)
-> ReflexTestT t intref out m b
$c>>= :: forall t intref out (m :: * -> *) a b.
Monad m =>
ReflexTestT t intref out m a
-> (a -> ReflexTestT t intref out m b)
-> ReflexTestT t intref out m b
Monad
, forall a. IO a -> ReflexTestT t intref out m a
forall {t} {intref} {out} {m :: * -> *}.
MonadIO m =>
Monad (ReflexTestT t intref out m)
forall t intref out (m :: * -> *) a.
MonadIO m =>
IO a -> ReflexTestT t intref out m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ReflexTestT t intref out m a
$cliftIO :: forall t intref out (m :: * -> *) a.
MonadIO m =>
IO a -> ReflexTestT t intref out m a
MonadIO
, forall a.
(a -> ReflexTestT t intref out m a) -> ReflexTestT t intref out m a
forall {t} {intref} {out} {m :: * -> *}.
MonadFix m =>
Monad (ReflexTestT t intref out m)
forall t intref out (m :: * -> *) a.
MonadFix m =>
(a -> ReflexTestT t intref out m a) -> ReflexTestT t intref out m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a.
(a -> ReflexTestT t intref out m a) -> ReflexTestT t intref out m a
$cmfix :: forall t intref out (m :: * -> *) a.
MonadFix m =>
(a -> ReflexTestT t intref out m a) -> ReflexTestT t intref out m a
MonadFix
, MonadReader (intref, out)
, MonadState (AppState t m))
deriving instance MonadSample t m => MonadSample t (ReflexTestT t intref out m)
deriving instance MonadHold t m => MonadHold t (ReflexTestT t intref out m)
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReflexTestT t intref out m)
instance MonadTrans (ReflexTestT t intref out) where
lift :: forall (m :: * -> *) a.
Monad m =>
m a -> ReflexTestT t intref out m a
lift = forall t intref out (m :: * -> *) a.
ReaderT (intref, out) (StateT (AppState t m) m) a
-> ReflexTestT t intref out m a
ReflexTestT 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 (MonadSubscribeEvent t m) => MonadSubscribeEvent t (ReflexTestT t intref out m) where
subscribeEvent :: forall a. Event t a -> ReflexTestT t intref out m (EventHandle t a)
subscribeEvent = 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.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent
instance (MonadRef m) => MonadReflexTest t (ReflexTestT t intref out m) where
type InputTriggerRefs (ReflexTestT t intref out m) = intref
type OutputEvents (ReflexTestT t intref out m) = out
type InnerMonad (ReflexTestT t intref out m) = m
inputTriggerRefs :: ReflexTestT
t intref out m (InputTriggerRefs (ReflexTestT t intref out m))
inputTriggerRefs = do
(intref
intref,out
_) <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return intref
intref
queueEventTrigger :: DSum (EventTrigger t) Identity -> ReflexTestT t intref out m ()
queueEventTrigger DSum (EventTrigger t) Identity
evt = do
AppState t m
as <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ AppState t m
as { _appState_queuedEvents :: [DSum (EventTrigger t) Identity]
_appState_queuedEvents = DSum (EventTrigger t) Identity
evt forall a. a -> [a] -> [a]
: forall t (m :: * -> *).
AppState t m -> [DSum (EventTrigger t) Identity]
_appState_queuedEvents AppState t m
as }
queueEventTriggerRef :: forall a.
Ref
(InnerMonad (ReflexTestT t intref out m))
(Maybe (EventTrigger t a))
-> a -> ReflexTestT t intref out m ()
queueEventTriggerRef Ref
(InnerMonad (ReflexTestT t intref out m))
(Maybe (EventTrigger t a))
ref a
a = do
Maybe (EventTrigger t a)
mpulse <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef Ref
(InnerMonad (ReflexTestT t intref out m))
(Maybe (EventTrigger t a))
ref
case Maybe (EventTrigger t a)
mpulse of
Maybe (EventTrigger t a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just EventTrigger t a
pulse -> do
AppState t m
as <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ AppState t m
as { _appState_queuedEvents :: [DSum (EventTrigger t) Identity]
_appState_queuedEvents = (EventTrigger t a
pulse forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity a
a) forall a. a -> [a] -> [a]
: forall t (m :: * -> *).
AppState t m -> [DSum (EventTrigger t) Identity]
_appState_queuedEvents AppState t m
as }
outputs :: ReflexTestT
t intref out m (OutputEvents (ReflexTestT t intref out m))
outputs = do
(intref
_,out
out) <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return out
out
fireQueuedEventsAndRead :: forall a.
ReadPhase (InnerMonad (ReflexTestT t intref out m)) a
-> ReflexTestT t intref out m [a]
fireQueuedEventsAndRead ReadPhase (InnerMonad (ReflexTestT t intref out m)) a
rp = do
AppState t m
as <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ AppState t m
as { _appState_queuedEvents :: [DSum (EventTrigger t) Identity]
_appState_queuedEvents = [] }
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall t (m :: * -> *).
FireCommand t m
-> forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
runFireCommand forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *). AppState t m -> FireCommand t m
_appState_fire AppState t m
as) (forall t (m :: * -> *).
AppState t m -> [DSum (EventTrigger t) Identity]
_appState_queuedEvents AppState t m
as) ReadPhase (InnerMonad (ReflexTestT t intref out m)) a
rp
runReflexTestT
:: forall intref inev out t m a
. (TestGuestConstraints t m)
=> (inev, intref)
-> (inev -> TestGuestT t m out)
-> ReflexTestT t intref out m a
-> m ()
runReflexTestT :: forall intref inev out t (m :: * -> *) a.
TestGuestConstraints t m =>
(inev, intref)
-> (inev -> TestGuestT t m out)
-> ReflexTestT t intref out m a
-> m ()
runReflexTestT (inev
input, intref
inputTRefs) inev -> TestGuestT t m out
app ReflexTestT t intref out m a
rtm = do
(Event t ()
postBuild, IORef (Maybe (EventTrigger t ()))
postBuildTriggerRef) <- forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef
Chan [DSum (EventTriggerRef t) TriggerInvocation]
events <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Chan a)
newChan
(out
output, fc :: FireCommand t m
fc@(FireCommand forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire)) <- do
forall t (m :: * -> *) a.
(Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m,
Ref m ~ Ref IO) =>
PerformEventT t m a -> m (a, FireCommand t m)
hostPerformEventT
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
runPostBuildT Event t ()
postBuild
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
runTriggerEventT Chan [DSum (EventTriggerRef t) TriggerInvocation]
events
forall a b. (a -> b) -> a -> b
$ inev -> TestGuestT t m out
app inev
input
Maybe (EventTrigger t ())
mPostBuildTrigger <- forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t ()))
postBuildTriggerRef
[()]
_ <- case Maybe (EventTrigger t ())
mPostBuildTrigger of
Maybe (EventTrigger t ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [()]
Just EventTrigger t ()
postBuildTrigger ->
forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire [EventTrigger t ()
postBuildTrigger forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity ()] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 t (m :: * -> *).
[DSum (EventTrigger t) Identity] -> FireCommand t m -> AppState t m
AppState [] FireCommand t m
fc)
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (intref
inputTRefs, out
output)
forall a b. (a -> b) -> a -> b
$ forall t intref out (m :: * -> *) a.
ReflexTestT t intref out m a
-> ReaderT (intref, out) (StateT (AppState t m) m) a
unReflexTestM ReflexTestT t intref out m a
rtm
return ()
class ReflexTestApp app t m | app -> t m where
data AppInputTriggerRefs app :: Type
data AppInputEvents app :: Type
data AppOutput app :: Type
getApp :: AppInputEvents app -> TestGuestT t m (AppOutput app)
makeInputs :: m (AppInputEvents app, AppInputTriggerRefs app)
runReflexTestApp
:: (ReflexTestApp app t m, TestGuestConstraints t m)
=> ReflexTestT t (AppInputTriggerRefs app) (AppOutput app) m ()
-> m ()
runReflexTestApp :: forall app t (m :: * -> *).
(ReflexTestApp app t m, TestGuestConstraints t m) =>
ReflexTestT t (AppInputTriggerRefs app) (AppOutput app) m ()
-> m ()
runReflexTestApp ReflexTestT t (AppInputTriggerRefs app) (AppOutput app) m ()
rtm = do
(AppInputEvents app, AppInputTriggerRefs app)
i <- forall app t (m :: * -> *).
ReflexTestApp app t m =>
m (AppInputEvents app, AppInputTriggerRefs app)
makeInputs
forall intref inev out t (m :: * -> *) a.
TestGuestConstraints t m =>
(inev, intref)
-> (inev -> TestGuestT t m out)
-> ReflexTestT t intref out m a
-> m ()
runReflexTestT (AppInputEvents app, AppInputTriggerRefs app)
i forall app t (m :: * -> *).
ReflexTestApp app t m =>
AppInputEvents app -> TestGuestT t m (AppOutput app)
getApp ReflexTestT t (AppInputTriggerRefs app) (AppOutput app) m ()
rtm