test/Reflex/Plan/Pure.hs · patch

64 lines 1.8 kB history raw

1{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

3module Reflex.Plan.Pure where

5import Reflex

6import Reflex.Pure

7import Reflex.TestPlan

9import Control.Applicative

10import Control.Monad.Fix

11import Control.Monad.State

12import Data.IntMap (IntMap)

13import qualified Data.IntMap as IntMap

14import Data.IntSet (IntSet)

15import qualified Data.IntSet as IntSet

17import Data.Monoid

18import Data.Bifunctor

19import Data.Maybe

20import Prelude

23mapToPureEvent :: IntMap a -> Event (Pure Int) a

24mapToPureEvent m = Event $ flip IntMap.lookup m

26type TimeM = (->) Int

27newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)

29liftPlan :: TimeM a -> PurePlan a

30liftPlan = PurePlan . lift

32instance MonadHold (Pure Int) PurePlan where

33 hold initial = liftPlan . hold initial

34 holdDyn initial = liftPlan . holdDyn initial

35 holdIncremental initial = liftPlan . holdIncremental initial

37instance MonadSample (Pure Int) PurePlan where

38 sample = liftPlan . sample

41instance TestPlan (Pure Int) PurePlan where

42 plan occs = do

43 PurePlan . modify $ IntSet.union (IntMap.keysSet m)

44 return $ mapToPureEvent m

45 where m = IntMap.fromList (first fromIntegral <$> occs)

47runPure :: PurePlan a -> (a, IntSet)

48runPure (PurePlan p) = runStateT p mempty $ 0

50relavantTimes :: IntSet -> IntSet

51relavantTimes occs = IntSet.fromList [0..l + 1]

52 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

54testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

55testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)

57testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

58testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)