summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpdlla <>2020-05-22 17:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-05-22 17:11:00 (GMT)
commite5296a2b892db11abc344836318b8ae706ce3f49 (patch)
treefc68f42c3945df585eb2d2f6571f34fbae7c6c90
parentf48d27c1a2e89e920d61f7eec1a2af24de3bfecc (diff)
version 0.1.1.00.1.1.0
-rwxr-xr-xChangeLog.md7
-rwxr-xr-xREADME.md8
-rw-r--r--reflex-test-host.cabal4
-rw-r--r--src/Reflex/Test/Host.hs103
-rw-r--r--test/Reflex/Test/HostSpec.hs33
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