diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,8 @@ # Changelog for reflex-test-host +## 0.1.2.0 +- added `Reflex.Test.Monad.Host` + ## 0.1.1.0 - generalized reflex constraints - added `PostBuildT` support diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# reflex-test-app +# reflex-test-host 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). diff --git a/reflex-test-host.cabal b/reflex-test-host.cabal --- a/reflex-test-host.cabal +++ b/reflex-test-host.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: f349f220ed538f9eea356a8e92d10740b0397a12f201007808bf995d552a0513 +-- hash: 17e1fcd46f7b753b5168f295d2feefbd6f430a25c8ba76ed9af2335ee1bfaff3 name: reflex-test-host -version: 0.1.1.0 +version: 0.1.2.0 synopsis: reflex host methods for testing without external events description: Please see the README on GitHub at category: FRP, Reflex @@ -30,6 +30,8 @@ library exposed-modules: Reflex.Test.Host + Reflex.Test.SimpleHost + Reflex.Test.Monad.Host other-modules: Paths_reflex_test_host hs-source-dirs: @@ -39,16 +41,21 @@ build-depends: base >=4.7 && <5 , dependent-sum + , lens + , mtl + , primitive , ref-tf , reflex , these + , transformers default-language: Haskell2010 test-suite reflex-test-host-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Reflex.Test.HostSpec + Reflex.Test.Monad.HostSpec + Reflex.Test.SimpleHostSpec Paths_reflex_test_host hs-source-dirs: test @@ -60,8 +67,12 @@ , dependent-sum , hspec , hspec-contrib + , lens + , mtl + , primitive , ref-tf , reflex , reflex-test-host , these + , transformers default-language: Haskell2010 diff --git a/src/Reflex/Test/Host.hs b/src/Reflex/Test/Host.hs --- a/src/Reflex/Test/Host.hs +++ b/src/Reflex/Test/Host.hs @@ -4,195 +4,12 @@ -- Module: -- Reflex.Test.Host -- Description: --- This module contains reflex host methods for testing without external events +-- DEPRECATED use 'Reflex.Test.SimpleHost' instead +-- reexports 'Reflex.Test.SimpleHost' module Reflex.Test.Host - ( TestGuestConstraints - , TestGuestMonad - , AppIn(..) - , AppOut(..) - , AppFrame(..) - , getAppFrame - , tickAppFrame - , runAppSimple - , runApp - , runApp' - , runAppB + ( module Reflex.Test.SimpleHost ) 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.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 - } - -data AppOut t b e = AppOut - { _appOut_behavior :: Behavior t b - , _appOut_event :: Event t e - } - -data AppFrame t bIn eIn bOut eOut m = AppFrame - { _appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut) - , _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. This will also fire the 'PostBuild' event if there --- are any subscribers. -getAppFrame - :: forall t bIn eIn bOut eOut m - . (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 $ 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 - let readPhase = do - b <- sample (_appOut_behavior out) - frames <- sequence =<< readEvent hnd - return (b, frames) - return AppFrame { _appFrame_readPhase = readPhase - , _appFrame_mpulseB = mpulseB - , _appFrame_mpulseE = mpulseE - , _appFrame_fire = fire - } - --- | Tick an app frame once with optional input behavior and event values. --- Returns behaviors and events from the app's output for each frame that run --- for the input (i.e. 'runWithAdjust' and 'performEvent' may cause several --- frames to run for each input) --- --- N.B. output behavior will not reflect changes that happen during its frame --- i.e. this is analogous to 'tag' and 'tagPromptlyDyn'. If you need the most --- recent behavior value you can always call 'tickAppFrame' with 'Nothing' as --- input -tickAppFrame - :: AppFrame t bIn eIn bOut eOut m - -> Maybe (These bIn eIn) - -> m [(bOut, Maybe eOut)] -tickAppFrame AppFrame {..} input = r where - fire = _appFrame_fire - readPhase = _appFrame_readPhase - 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 -> TestGuestMonad t m (AppOut t bOut eOut)) - -> bIn - -> [Maybe (These bIn eIn)] - -> IO [[(bOut, Maybe eOut)]] -runApp app b0 input = runSpiderHost $ do - appFrame <- getAppFrame app b0 - forM input $ tickAppFrame appFrame - --- | run an app with provided list of input events returns list of results for --- each input. Each result is a list of events from the app's output for each --- frame that run for the input. --- see comments for 'tickAppFrame' -runAppSimple - :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) - => (Event t eIn -> TestGuestMonad t m (Event t eOut)) - -> [eIn] - -> IO [[Maybe eOut]] -runAppSimple app input = runApp' app (map Just input) - --- | same as runAppSimple except input event for each frame is optional --- see comments for 'tickAppFrame' -runApp' - :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) - => (Event t eIn -> TestGuestMonad t m (Event t eOut)) - -> [Maybe eIn] - -> IO [[Maybe eOut]] -runApp' app input = do - let app' = fmap (AppOut (pure ())) . app - map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input) - --- | same as runApp' except only returns sampled output behavior --- see comments for 'tickAppFrame' -runAppB - :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) - => (Event t eIn -> TestGuestMonad t m (Behavior t bOut)) - -> [Maybe eIn] - -> IO [[bOut]] -runAppB app input = do - let app' = fmap (flip AppOut never) . app - map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input) +import Reflex.Test.SimpleHost diff --git a/src/Reflex/Test/Monad/Host.hs b/src/Reflex/Test/Monad/Host.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Test/Monad/Host.hs @@ -0,0 +1,197 @@ + + + + +-- | +-- 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 + 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 diff --git a/src/Reflex/Test/SimpleHost.hs b/src/Reflex/Test/SimpleHost.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Test/SimpleHost.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: +-- Reflex.Test.SimpleHost +-- Description: +-- This module contains reflex host methods for testing without external events + +module Reflex.Test.SimpleHost + ( TestGuestConstraints + , TestGuestT + , AppIn(..) + , AppOut(..) + , AppFrame(..) + , getAppFrame + , tickAppFrame + , runAppSimple + , runApp + , runApp' + , runAppB + ) +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.Kind +import Data.These + +import Reflex +import Reflex.Host.Class + + +type TestGuestT t (m :: Type -> Type) = PostBuildT t (PerformEventT t m) + +-- 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 + ) + +data AppIn t b e = AppIn + { _appIn_behavior :: Behavior t b + , _appIn_event :: Event t e + } + +data AppOut t b e = AppOut + { _appOut_behavior :: Behavior t b + , _appOut_event :: Event t e + } + +data AppFrame t bIn eIn bOut eOut m = AppFrame + { _appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut) + , _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. This will also fire the 'PostBuild' event if there +-- are any subscribers. +getAppFrame + :: forall t bIn eIn bOut eOut m + . (TestGuestConstraints t m) + => (AppIn t bIn eIn -> TestGuestT 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 $ 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 + let readPhase = do + b <- sample (_appOut_behavior out) + frames <- sequence =<< readEvent hnd + return (b, frames) + return AppFrame { _appFrame_readPhase = readPhase + , _appFrame_mpulseB = mpulseB + , _appFrame_mpulseE = mpulseE + , _appFrame_fire = fire + } + +-- | Tick an app frame once with optional input behavior and event values. +-- Returns behaviors and events from the app's output for each frame that run +-- for the input (i.e. 'runWithAdjust' and 'performEvent' may cause several +-- frames to run for each input) +-- +-- N.B. output behavior will not reflect changes that happen during its frame +-- i.e. this is analogous to 'tag' and 'tagPromptlyDyn'. If you need the most +-- recent behavior value you can always call 'tickAppFrame' with 'Nothing' as +-- input +tickAppFrame + :: AppFrame t bIn eIn bOut eOut m + -> Maybe (These bIn eIn) + -> m [(bOut, Maybe eOut)] +tickAppFrame AppFrame {..} input = r where + fire = _appFrame_fire + readPhase = _appFrame_readPhase + 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 -> TestGuestT t m (AppOut t bOut eOut)) + -> bIn + -> [Maybe (These bIn eIn)] + -> IO [[(bOut, Maybe eOut)]] +runApp app b0 input = runSpiderHost $ do + appFrame <- getAppFrame app b0 + forM input $ tickAppFrame appFrame + +-- | run an app with provided list of input events returns list of results for +-- each input. Each result is a list of events from the app's output for each +-- frame that run for the input. +-- see comments for 'tickAppFrame' +runAppSimple + :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> TestGuestT t m (Event t eOut)) + -> [eIn] + -> IO [[Maybe eOut]] +runAppSimple app input = runApp' app (map Just input) + +-- | same as runAppSimple except input event for each frame is optional +-- see comments for 'tickAppFrame' +runApp' + :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> TestGuestT t m (Event t eOut)) + -> [Maybe eIn] + -> IO [[Maybe eOut]] +runApp' app input = do + let app' = fmap (AppOut (pure ())) . app + map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input) + +-- | same as runApp' except only returns sampled output behavior +-- see comments for 'tickAppFrame' +runAppB + :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> TestGuestT t m (Behavior t bOut)) + -> [Maybe eIn] + -> IO [[bOut]] +runAppB app input = do + let app' = fmap (flip AppOut never) . app + map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input) diff --git a/test/Reflex/Test/HostSpec.hs b/test/Reflex/Test/HostSpec.hs deleted file mode 100644 --- a/test/Reflex/Test/HostSpec.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module Reflex.Test.HostSpec - ( spec - ) -where - -import Prelude - -import Test.Hspec -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 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 -> 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) - $ attach _appIn_behavior _appIn_event - } - -test_basic :: Test -test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ do - let b = 10 :: Int - es = [1 .. 10] :: [Int] - appFrame <- getAppFrame basic_network b - forM_ es $ \e -> do - out <- tickAppFrame appFrame (Just (That e)) - liftIO $ L.last out @?= (-b, Just (b + e)) - -spec :: Spec -spec = describe "Reflex.Test.App" $ do - fromHUnitTest test_basic - fromHUnitTest test_postbuild diff --git a/test/Reflex/Test/Monad/HostSpec.hs b/test/Reflex/Test/Monad/HostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Test/Monad/HostSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +module Reflex.Test.Monad.HostSpec + ( spec + ) +where + +import Prelude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Control.Monad.IO.Class (liftIO) +import Data.Kind + +import Reflex +import Reflex.Host.Class +import Reflex.Test.Monad.Host + + +-- | a very basic test network, simple passes on the input event to its observed outputs +basic_network :: forall t m. (ReflexHost t) + => (Event t Int -> TestGuestT t m (Event t Int)) +basic_network ev = return ev + +-- | test 'basic_network' +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ do + ins <- newEventWithTriggerRef + runReflexTestT ins basic_network $ do + + -- get our app's output events and subscribe to them + oh <- subscribeEvent =<< outputs + -- get our input trigger ref, dereference it, queue it and fire it + intref <- inputTriggerRefs + + -- example of how to manually dereferences our input trigger + {- + mh :: Maybe (EventTrigger T Int) <- liftIO $ readRef intref + case mh of + Just h -> queueEventTrigger $ (h :=> Identity 0) + Nothing -> error "no subscribers to h" + -} + + -- simpler version that uses 'queueEventTriggerRef' + queueEventTriggerRef intref 123 + + -- fire the events and read from our output handle + a <- fireQueuedEventsAndRead $ sequence =<< readEvent oh + + -- validate results + liftIO $ a @?= [Just 123] + +data BasicNetworkTest1 t (m :: Type -> Type) + +instance (TestGuestConstraints t m) => ReflexTestApp (BasicNetworkTest1 t m) t m where + data AppInputTriggerRefs (BasicNetworkTest1 t m) = + BasicNetworkTest1_InputTriggerRefs { _basicNetworkTest1_InputTriggerRefs_intEvTRef :: ReflexTriggerRef t m Int } + data AppInputEvents (BasicNetworkTest1 t m) = + BasicNetworkTest1_InputEvents { _basicNetworkTest1_InputEvents_intEv :: Event t Int } + data AppOutput (BasicNetworkTest1 t m) = + BasicNetworkTest1_Output { _basicNetworkTest1_Output_intEv :: Event t Int } + getApp ev = basic_network (_basicNetworkTest1_InputEvents_intEv ev) >>= return . BasicNetworkTest1_Output + makeInputs = do + (inev, intref) <- newEventWithTriggerRef + return (BasicNetworkTest1_InputEvents inev, BasicNetworkTest1_InputTriggerRefs intref) + +test_basic_viaReflexTestApp :: Test +test_basic_viaReflexTestApp = TestLabel "basic_viaReflexTestApp" $ TestCase $ runSpiderHost $ + runReflexTestApp @ (BasicNetworkTest1 (SpiderTimeline Global) (SpiderHost Global)) $ do + -- get our app's output events and subscribe to them + BasicNetworkTest1_Output {..} <- outputs + oh <- subscribeEvent _basicNetworkTest1_Output_intEv + -- get our input trigger ref, dereference it, queue it and fire it + BasicNetworkTest1_InputTriggerRefs{..} <- inputTriggerRefs + + -- simpler version that uses 'queueEventTriggerRef' + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_intEvTRef 123 + + -- fire the events and read from our output handle + a <- fireQueuedEventsAndRead $ sequence =<< readEvent oh + + -- validate results + liftIO $ a @?= [Just 123] + + +spec :: Spec +spec = do + fromHUnitTest test_basic + fromHUnitTest test_basic_viaReflexTestApp diff --git a/test/Reflex/Test/SimpleHostSpec.hs b/test/Reflex/Test/SimpleHostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Test/SimpleHostSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Reflex.Test.SimpleHostSpec + ( spec + ) +where + +import Prelude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Reflex +import Reflex.Test.SimpleHost + +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 () () -> TestGuestT 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 -> TestGuestT t m (AppOut t Int Int)) +basic_network AppIn {..} = return AppOut + { _appOut_behavior = fmap (* (-1)) _appIn_behavior + , _appOut_event = fmap (\(b, e) -> e + b) + $ attach _appIn_behavior _appIn_event + } + +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ do + let b = 10 :: Int + es = [1 .. 10] :: [Int] + appFrame <- getAppFrame basic_network b + forM_ es $ \e -> do + out <- tickAppFrame appFrame (Just (That e)) + liftIO $ L.last out @?= (-b, Just (b + e)) + +spec :: Spec +spec = do + fromHUnitTest test_basic + fromHUnitTest test_postbuild