Add testing host methods

cabal.project.local

@@ -0,0 +1,6 @@
+
+package *
+  ghc-location: ghc
+
+program-locations
+  ghc-location: ghc

reflex.cabal

@@ -145,6 +145,8 @@ library
     Reflex.Requester.Class,
     Reflex.Spider,
     Reflex.Spider.Internal,
+    Reflex.Test.SimpleHost
+    Reflex.Test.Monad.Host
     Reflex.Time,
     Reflex.TriggerEvent.Base,
     Reflex.TriggerEvent.Class,
@@ -248,6 +250,36 @@ test-suite CrossImpl
     Reflex.Plan.Reflex
     Reflex.Plan.Pure
 
+test-suite MonadHostSpec
+  type: exitcode-stdio-1.0
+  main-is: Reflex/Test/Monad/HostSpec.hs
+  hs-source-dirs: test
+  default-extensions:
+  ghc-options: -O2 -Wall -rtsopts
+  build-depends:
+    base
+    , these
+    , HUnit
+    , hspec
+    , hspec-contrib
+    , reflex
+  default-language: Haskell2010
+
+test-suite SimpleHostSpec
+  type: exitcode-stdio-1.0
+  main-is: Reflex/Test/SimpleHostSpec.hs
+  hs-source-dirs: test
+  default-extensions:
+  ghc-options: -O2 -Wall -rtsopts
+  build-depends:
+    base
+    , these
+    , HUnit
+    , hspec
+    , hspec-contrib
+    , reflex
+  default-language: Haskell2010
+
 test-suite hlint
   default-language: Haskell2010
   type: exitcode-stdio-1.0
@@ -284,9 +316,6 @@ test-suite EventWriterT
   if flag(split-these)
     build-depends: these-lens
 
-  other-modules:
-    Test.Run
-
 
 test-suite DebugCycles
   default-language: Haskell2010
@@ -313,9 +342,6 @@ test-suite DebugCycles
   if flag(split-these)
     build-depends: these-lens, semialign
 
-  other-modules:
-    Test.Run
-
 
 test-suite RequesterT
   default-language: Haskell2010
@@ -343,7 +369,6 @@ test-suite RequesterT
   other-modules:
     Reflex.TestPlan
     Reflex.Plan.Pure
-    Test.Run
 
 test-suite Headless
   default-language: Haskell2010
@@ -365,9 +390,6 @@ test-suite Adjustable
                , ref-tf
                , these
 
-  other-modules:
-    Test.Run
-
 test-suite QueryT
   default-language: Haskell2010
   type: exitcode-stdio-1.0
@@ -391,7 +413,6 @@ test-suite QueryT
     build-depends: semialign, these-lens
 
   other-modules:
-    Test.Run
     Reflex.TestPlan
     Reflex.Plan.Reflex
     Reflex.Plan.Pure
@@ -420,7 +441,6 @@ test-suite GC-Semantics
     Reflex.Plan.Pure
     Reflex.Plan.Reflex
     Reflex.TestPlan
-    Test.Run
 
 test-suite rootCleanup
   default-language: Haskell2010
@@ -438,7 +458,6 @@ test-suite rootCleanup
   other-modules:
     Reflex.Plan.Pure
     Reflex.TestPlan
-    Test.Run
 
 benchmark spider-bench
   default-language: Haskell2010

src/Reflex/Test/Monad/Host.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+
+
+-- |
+-- Module:
+--   Reflex.Test.Monad.Host
+-- Description:
+--   This module contains a monad for testing reflex networks
+
+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
+    )
+
+-- | since we work with this type directly a lot, it helps to wrap it around a type synonym
+type ReflexTriggerRef t (m :: Type -> Type) a = Ref m (Maybe (EventTrigger t a))
+
+-- |
+class MonadReflexTest t m | m -> t  where
+  -- | since event subscriptions also happen within the monad, input triggers created via 'newEventWithTriggerRef' may be stuck in the 'Nothing' state as there are no listeners yet
+  -- therefore it's necessary to pass in IORefs to the EventTriggers, thus the name of this type
+  -- in practice, this will likely be a record containing many trigger refs and the monad user must deref them all
+  type InputTriggerRefs m :: Type
+  -- | in practice, this will likely be a record containing events and behaviors for the monad user to build a 'ReadPhase' that is passed into 'fireQueuedEventsAndRead'
+  type OutputEvents m :: Type
+  -- | the inner monad that reflex is running in
+  -- likely 'SpiderHost Global'
+  type InnerMonad m :: Type -> Type
+  -- | see comments for 'InputTriggerRefs'
+  inputTriggerRefs :: m (InputTriggerRefs m)
+  -- | all queued triggers will fire simultaneous on the next execution of 'fireQueuedEventsAndRead'
+  queueEventTrigger :: DSum (EventTrigger t) Identity -> m ()
+  -- | same as 'queueEventTrigger' except works with trigger refs
+  -- if the trigger ref derefs to 'Nothing', the event does not get queued
+  queueEventTriggerRef :: Ref (InnerMonad m) (Maybe (EventTrigger t a)) -> a -> m ()
+  -- | see comments for 'OutputEvents'
+  outputs :: m (OutputEvents m)
+  -- | fire all queued events and run a ReadPhase to produce results from the execution frames
+  -- readphase takes place in the inner monad
+  fireQueuedEventsAndRead :: ReadPhase (InnerMonad m) a -> m [a]
+
+-- m is 'InnerMonad' from above
+data AppState t m = AppState
+    { _appState_queuedEvents :: [DSum (EventTrigger t) Identity] -- ^ events to fire in next 'FireCommand'
+    -- ^ 'FireCommand' to fire events and run next frame
+    , _appState_fire         :: FireCommand t m -- ^ 'FireCommand' to fire events and run next frame
+    }
+
+-- | implementation of 'MonadReflexTest'
+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
+    put $ as { _appState_queuedEvents = [] }
+    lift $ (runFireCommand $ _appState_fire as) (_appState_queuedEvents as) rp
+
+runReflexTestT
+  :: forall intref inev out t m a
+   . (TestGuestConstraints t m)
+  => (inev, intref) -- ^ make sure intref match inev, i.e. return values of newEventWithTriggerRef
+  -> (inev -> TestGuestT t m out) -- ^ network to test
+  -> ReflexTestT t intref out m a -- ^ test monad to run
+  -> 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
+
+  -- handle post build
+  -- TODO consider adding some way to test 'PostBuild' results
+  mPostBuildTrigger <- readRef postBuildTriggerRef
+  _                 <- case mPostBuildTrigger of
+    Nothing -> return [()] -- no subscribers
+    Just postBuildTrigger ->
+      fire [postBuildTrigger :=> Identity ()] $ return ()
+
+  -- TODO maybe find a way to handle trigger events
+  -- one solution is to implement non-blocking variant of TriggerEventT
+  -- and then pass as part of AppState such that each call to readPhase will fire any trigger events
+  -- another option is just to start a thread and output warnings anytime triggerEvs are created
+  --triggerEvs <- liftIO $ readChan events
+
+  -- run the test monad
+  _ <- flip runStateT (AppState [] fc)
+    $ flip runReaderT (inputTRefs, output)
+      $ unReflexTestM rtm
+
+  return ()
+
+
+
+-- | class to help bind network and types to a 'ReflexTestT'
+-- see test/Reflex/Test/Monad/HostSpec.hs for usage example
+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