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.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]
data AppState t m = AppState
{ _appState_queuedEvents :: [DSum (EventTrigger t) Identity]
, _appState_fire :: FireCommand t m
}
newtype ReflexTestT t intref out m a = ReflexTestT { unReflexTestM :: ReaderT (intref, out) (StateT (AppState t m) m) a }
deriving
( Functor
, Applicative
, Monad
, MonadIO
, 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 = ReflexTestT . lift . lift
instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (ReflexTestT t intref out m) where
subscribeEvent = lift . 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 = do
(intref,_) <- ask
return intref
queueEventTrigger evt = do
as <- get
put $ as { _appState_queuedEvents = evt : _appState_queuedEvents as }
queueEventTriggerRef ref a = do
mpulse <- lift $ readRef ref
case mpulse of
Nothing -> return ()
Just pulse -> do
as <- get
put $ as { _appState_queuedEvents = (pulse :=> Identity a) : _appState_queuedEvents as }
outputs = do
(_,out) <- ask
return out
fireQueuedEventsAndRead rp = do
as <- get
lift $ (runFireCommand $ _appState_fire as) (_appState_queuedEvents as) 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 (input, inputTRefs) app rtm = do
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
events <- liftIO newChan
(output, fc@(FireCommand fire)) <- do
hostPerformEventT
$ flip runPostBuildT postBuild
$ flip runTriggerEventT events
$ app input
mPostBuildTrigger <- readRef postBuildTriggerRef
_ <- case mPostBuildTrigger of
Nothing -> return [()]
Just postBuildTrigger ->
fire [postBuildTrigger :=> Identity ()] $ return ()
flip runStateT (AppState [] fc)
$ flip runReaderT (inputTRefs, output)
$ unReflexTestM 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 rtm = do
i <- makeInputs
runReflexTestT i getApp rtm