git.iko.soy/reflex
on develop help sign in
reflex/test/Reflex/Plan/Reflex.hs
135 lines 4.4 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE UndecidableInstances #-}
11module Reflex.Plan.Reflex
12 ( TestPlan(..)
13 , runPlan
14 , Plan (..)
15 , Schedule
16 , Firing (..)
17 , MonadIORef
20 , readSchedule
21 , readSchedule_
22 , testSchedule
23 , readEvent'
24 , makeDense
26 , runTestE
27 , runTestB
29 ) where
31import Reflex.Class
32import Reflex.Host.Class
33import Reflex.TestPlan
35import Control.Applicative
36import Control.Monad
37import Control.Monad.Identity
38import Control.Monad.State.Strict
40import Control.Monad.Ref
41import Data.Dependent.Sum (DSum (..))
42import qualified Data.IntMap.Strict as IntMap
43import Data.Maybe
44import Data.Monoid
45import Data.Traversable (sequenceA, traverse)
47import Control.DeepSeq
48import Control.Exception
49import Data.IntMap.Strict (IntMap)
50import Data.IORef
51import System.Mem
53-- Note: this import must come last to silence warnings from AMP
54import Prelude
56type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
58data Firing t where
59 Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
62type Schedule t = IntMap [Firing t]
64-- Implementation of a TestPlan in terms of ReflexHost
65newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
67deriving instance ReflexHost t => Functor (Plan t)
68deriving instance ReflexHost t => Applicative (Plan t)
69deriving instance ReflexHost t => Monad (Plan t)
71deriving instance ReflexHost t => MonadSample t (Plan t)
72deriving instance ReflexHost t => MonadHold t (Plan t)
73deriving instance ReflexHost t => MonadFix (Plan t)
76instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
77 plan occurrences = Plan $ do
78 (e, ref) <- newEventWithTriggerRef
79 modify (IntMap.unionWith mappend (firings ref))
80 return e
82 where
83 firings ref = IntMap.fromList (makeFiring ref <$> occurrences)
84 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
87firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
88firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
90runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)
91runPlan (Plan p) = runHostFrame $ runStateT p mempty
94makeDense :: Schedule t -> Schedule t
95makeDense s = fromMaybe (emptyRange 0) $ do
96 (end, _) <- fst <$> IntMap.maxViewWithKey s
97 return $ IntMap.union s (emptyRange end)
98 where
99 emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
102-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
103-- after the last event)
104-- performGC is called at each frame to test for GC issues
105testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
106testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
108readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
109readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
111readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()
112readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule
114triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a
115triggerFrame readResult _ occs = do
116 triggers <- catMaybes <$> traverse firingTrigger occs
117 liftIO . evaluate . force =<< fireEventsAndRead triggers readResult
119readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
120readEvent' = readEvent >=> sequenceA
123-- Convenience functions for running tests producing Events/Behaviors
124runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)
125runTestB p = do
126 (b, s) <- runPlan p
127 testSchedule s $ sample b
129runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))
130runTestE p = do
131 (e, s) <- runPlan p
132 h <- subscribeEvent e
133 testSchedule s (readEvent' h)