diff options
author | pdlla <> | 2020-05-22 17:11:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2020-05-22 17:11:00 (GMT) |
commit | e5296a2b892db11abc344836318b8ae706ce3f49 (patch) | |
tree | fc68f42c3945df585eb2d2f6571f34fbae7c6c90 | |
parent | f48d27c1a2e89e920d61f7eec1a2af24de3bfecc (diff) |
version 0.1.1.00.1.1.0
-rwxr-xr-x | ChangeLog.md | 7 | ||||
-rwxr-xr-x | README.md | 8 | ||||
-rw-r--r-- | reflex-test-host.cabal | 4 | ||||
-rw-r--r-- | src/Reflex/Test/Host.hs | 103 | ||||
-rw-r--r-- | test/Reflex/Test/HostSpec.hs | 33 |
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 @@ -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 |