version 0.1.1.00.1.1.0

5 files changed, 112 insertions, 43 deletions

diff --git a/ChangeLog.md b/ChangeLog.md
index c705fdc..becc070 100755
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,4 +1,9 @@
 # Changelog for reflex-test-host
 
+## 0.1.1.0
+- generalized reflex constraints
+- added `PostBuildT` support
+- fixed a crash that would happen if there were no event subscribers
+
 ## 0.1.0.0
-first release
+- first release
diff --git a/README.md b/README.md
index 3bc840f..229b439 100755
--- a/README.md
+++ b/README.md
@@ -1,12 +1,8 @@
 # reflex-test-app
 
-This library contains functionality for writing unit tests for the "model" portion of your reflex-frp apps. Please see `test/Reflex/Test/App.hs` for basic usage example.
+This library contains functionality for writing unit tests for the "model" portion of your reflex-frp apps. Please see `test/Reflex/Test/App.hs` for basic usage example. You can find more usage examples in [this project](https://github.com/pdlla/reflex-potatoes?files=1) and [this one](https://github.com/pdlla/reflex-todo-undo-mvc-model).
 
-Note that the following two reflex class constraints are not supported:
-
-- `PostBuild` could be added easily, but I noticed different hosts have different semantics on how to treat `PostBuild`, i.e. is it something that runs just ONCE after the first setup or after each frame. To avoid confusion, this library does not support the constraint though it could be added easily. For example, see [reflex-basic-host](https://github.com/qfpl/reflex-basic-host/).
-
-- `TriggerEvent` could also be added with some effort but breaks the "pureness" of the test (at least from its inputs) so I don't suggest it. You can still test parts of your network that don't require `TriggerEvent`
+Note that `TriggerEvent` class constraint is not supported. It could be added with some effort but breaks the "pureness" of the test (at least from its inputs) so I don't suggest it. You can still test parts of your network that don't require `TriggerEvent`.
 
 This library is modified from `test/Test/Run.hs` in the [reflex main repository](https://github.com/reflex-frp/reflex). I'll deprecate this module if the functionality is ever moved into an exposed module which [I think it should be](https://github.com/reflex-frp/reflex/issues/412).
 
diff --git a/reflex-test-host.cabal b/reflex-test-host.cabal
index 39df2f2..02489e1 100644
--- a/reflex-test-host.cabal
+++ b/reflex-test-host.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5ed3f299235faa921234096cca2fe127b6f0a9a8b4b49c9ce1178d3205a927b7
+-- hash: f349f220ed538f9eea356a8e92d10740b0397a12f201007808bf995d552a0513
 
 name:           reflex-test-host
-version:        0.1.0.0
+version:        0.1.1.0
 synopsis:       reflex host methods for testing without external events
 description:    Please see the README on GitHub at <https://github.com/pdlla/reflex-test-host#readme>
 category:       FRP, Reflex
diff --git a/src/Reflex/Test/Host.hs b/src/Reflex/Test/Host.hs
index 76e5b5f..2d2b914 100644
--- a/src/Reflex/Test/Host.hs
+++ b/src/Reflex/Test/Host.hs
@@ -7,7 +7,9 @@
 --   This module contains reflex host methods for testing without external events
 
 module Reflex.Test.Host
-  ( AppIn(..)
+  ( TestGuestConstraints
+  , TestGuestMonad
+  , AppIn(..)
   , AppOut(..)
   , AppFrame(..)
   , getAppFrame
@@ -22,15 +24,35 @@ where
 import           Prelude
 
 import           Control.Monad
+import           Control.Monad.Fix
+import           Control.Monad.IO.Class
 import           Control.Monad.Ref
 import           Data.Dependent.Sum
 import           Data.Functor.Identity
-import           Data.Maybe            (fromJust)
+import           Data.Kind
 import           Data.These
 
 import           Reflex
 import           Reflex.Host.Class
 
+
+-- TODO some of these constraints can be dropped probably
+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 TestGuestMonad t (m :: Type -> Type) = PostBuildT t (PerformEventT t m)
+
 data AppIn t b e = AppIn
     { _appIn_behavior :: Behavior t b
     , _appIn_event    :: Event t e
@@ -43,28 +65,50 @@ data AppOut t b e = AppOut
 
 data AppFrame t bIn eIn bOut eOut m = AppFrame
     { _appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut)
-    , _appFrame_pulseB :: EventTrigger t bIn
-    , _appFrame_pulseE :: EventTrigger t eIn
+    , _appFrame_mpulseB :: Maybe (EventTrigger t bIn)
+    , _appFrame_mpulseE :: Maybe (EventTrigger t eIn)
     , _appFrame_fire :: forall a .
   [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
     }
 
 -- | make an 'AppFrame' that takes an input behavior and event and returns an
--- output behavior and event.
+-- output behavior and event. This will also fire the 'PostBuild' event if there
+-- are any subscribers.
 getAppFrame
   :: forall t bIn eIn bOut eOut m
-   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut))
+   . (TestGuestConstraints t m)
+  => (AppIn t bIn eIn -> TestGuestMonad t m (AppOut t bOut eOut))
   -> bIn
   -> m (AppFrame t bIn eIn bOut eOut m)
 getAppFrame app b0 = do
+
+  -- Create the "post-build" event and associated trigger. This event fires
+  -- once, when the application starts.
+  (postBuild , postBuildTriggerRef ) <- newEventWithTriggerRef
+
+
+  -- Create input behavior, events, and  assosciated triggers.
   (appInHoldE, pulseHoldTriggerRef ) <- newEventWithTriggerRef
   (appInE    , pulseEventTriggerRef) <- newEventWithTriggerRef
   appInB                             <- hold b0 appInHoldE
+
+  -- Setup the app and obtain its output events and 'FireCommand'
   (out :: AppOut t bOut eOut, FireCommand fire) <-
-    hostPerformEventT $ app $ AppIn { _appIn_event    = appInE
-                                    , _appIn_behavior = appInB
-                                    }
+    hostPerformEventT $ flip runPostBuildT postBuild $ app $ AppIn
+      { _appIn_event    = appInE
+      , _appIn_behavior = appInB
+      }
+
+
+  -- Read the trigger reference for the post-build event. This will be
+  -- 'Nothing' if the guest application hasn't subscribed to this event.
+  mPostBuildTrigger <- readRef postBuildTriggerRef
+
+  -- When there is a subscriber to the post-build event, fire the event.
+  forM_ mPostBuildTrigger
+    $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
+
+  --
   hnd :: EventHandle t eOut <- subscribeEvent (_appOut_event out)
   mpulseB                   <- readRef pulseHoldTriggerRef
   mpulseE                   <- readRef pulseEventTriggerRef
@@ -73,8 +117,8 @@ getAppFrame app b0 = do
         frames <- sequence =<< readEvent hnd
         return (b, frames)
   return AppFrame { _appFrame_readPhase = readPhase
-                  , _appFrame_pulseB    = fromJust mpulseB
-                  , _appFrame_pulseE    = fromJust mpulseE
+                  , _appFrame_mpulseB   = mpulseB
+                  , _appFrame_mpulseE   = mpulseE
                   , _appFrame_fire      = fire
                   }
 
@@ -88,28 +132,31 @@ getAppFrame app b0 = do
 -- recent behavior value you can always call 'tickAppFrame' with 'Nothing' as
 -- input
 tickAppFrame
-  :: (t ~ SpiderTimeline Global)
-  => AppFrame t bIn eIn bOut eOut m
+  :: AppFrame t bIn eIn bOut eOut m
   -> Maybe (These bIn eIn)
   -> m [(bOut, Maybe eOut)]
-tickAppFrame AppFrame {..} input = case input of
-  Nothing -> fire [] $ readPhase
-  Just i  -> case i of
-    This b' -> fire [pulseB :=> Identity b'] $ readPhase
-    That e' -> fire [pulseE :=> Identity e'] $ readPhase
-    These b' e' ->
-      fire [pulseB :=> Identity b', pulseE :=> Identity e'] $ readPhase
- where
+tickAppFrame AppFrame {..} input = r where
   fire      = _appFrame_fire
   readPhase = _appFrame_readPhase
-  pulseB    = _appFrame_pulseB
-  pulseE    = _appFrame_pulseE
+  mpulseB   = _appFrame_mpulseB
+  mpulseE   = _appFrame_mpulseE
+  makeFiring mpulse v = case mpulse of
+    Just pulse -> [pulse :=> Identity v]
+    Nothing    -> []
+  firings = case input of
+    Nothing -> []
+    Just i  -> case i of
+      This b'     -> makeFiring mpulseB b'
+      That e'     -> makeFiring mpulseE e'
+      These b' e' -> makeFiring mpulseB b' <> makeFiring mpulseE e'
+  r = fire firings readPhase
+
 
 -- | calls 'tickAppFrame' for each input in a list and returns collected results
 -- see comments for 'tickAppFrame'
 runApp
   :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut))
+  => (AppIn t bIn eIn -> TestGuestMonad t m (AppOut t bOut eOut))
   -> bIn
   -> [Maybe (These bIn eIn)]
   -> IO [[(bOut, Maybe eOut)]]
@@ -123,7 +170,7 @@ runApp app b0 input = runSpiderHost $ do
 -- see comments for 'tickAppFrame'
 runAppSimple
   :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (Event t eIn -> PerformEventT t m (Event t eOut))
+  => (Event t eIn -> TestGuestMonad t m (Event t eOut))
   -> [eIn]
   -> IO [[Maybe eOut]]
 runAppSimple app input = runApp' app (map Just input)
@@ -132,7 +179,7 @@ runAppSimple app input = runApp' app (map Just input)
 -- see comments for 'tickAppFrame'
 runApp'
   :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (Event t eIn -> PerformEventT t m (Event t eOut))
+  => (Event t eIn -> TestGuestMonad t m (Event t eOut))
   -> [Maybe eIn]
   -> IO [[Maybe eOut]]
 runApp' app input = do
@@ -143,7 +190,7 @@ runApp' app input = do
 -- see comments for 'tickAppFrame'
 runAppB
   :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (Event t eIn -> PerformEventT t m (Behavior t bOut))
+  => (Event t eIn -> TestGuestMonad t m (Behavior t bOut))
   -> [Maybe eIn]
   -> IO [[bOut]]
 runAppB app input = do
diff --git a/test/Reflex/Test/HostSpec.hs b/test/Reflex/Test/HostSpec.hs
index 589ed53..38fab6d 100644
--- a/test/Reflex/Test/HostSpec.hs
+++ b/test/Reflex/Test/HostSpec.hs
@@ -1,5 +1,5 @@
+{-# LANGUAGE RankNTypes      #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE RankNTypes #-}
 
 module Reflex.Test.HostSpec
   ( spec
@@ -9,23 +9,43 @@ where
 import           Prelude
 
 import           Test.Hspec
-import           Test.Hspec.Contrib.HUnit       ( fromHUnitTest )
+import           Test.Hspec.Contrib.HUnit (fromHUnitTest)
 import           Test.HUnit
 
 import           Reflex
 import           Reflex.Test.Host
 
-import           Control.Monad                  ( forM_ )
-import           Control.Monad.IO.Class         ( liftIO )
-import qualified Data.List                     as L
+import           Control.Monad            (forM_)
+import           Control.Monad.IO.Class   (liftIO)
+import           Data.Functor
+import qualified Data.List                as L
 import           Data.These
 
 
+-- | network that ensures postbuild event was triggered
+postbuild_network
+  :: forall t m
+   . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
+  => (AppIn t () () -> TestGuestMonad t m (AppOut t Bool ()))
+postbuild_network AppIn {..} = do
+  pbev            <- getPostBuild
+  didPBTriggerBeh <- hold False (pbev $> True)
+  return AppOut { _appOut_behavior = didPBTriggerBeh, _appOut_event = never }
+
+test_postbuild :: Test
+test_postbuild = TestLabel "postbuild" $ TestCase $ runSpiderHost $ do
+  appFrame <- getAppFrame postbuild_network ()
+  -- tick the appFrame once which will give us the output behavior value of the previous frame (which triggered the postbuild event)
+  out      <- tickAppFrame appFrame (Just (That ()))
+  liftIO $ out @?= [(True, Nothing)]
+
 
+-- | Basic network that flips returns a behavior that is the input behavior flipped
+-- and an event that is the input behavior's value added to the input events value.
 basic_network
   :: forall t m
    . (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
-  => (AppIn t Int Int -> PerformEventT t m (AppOut t Int Int))
+  => (AppIn t Int Int -> TestGuestMonad t m (AppOut t Int Int))
 basic_network AppIn {..} = return AppOut
   { _appOut_behavior = fmap (* (-1)) _appIn_behavior
   , _appOut_event    = fmap (\(b, e) -> e + b)
@@ -44,3 +64,4 @@ test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ do
 spec :: Spec
 spec = describe "Reflex.Test.App" $ do
   fromHUnitTest test_basic
+  fromHUnitTest test_postbuild