git.iko.soy/reflex
on 8246ce1 help sign in
90891e1
swap
7 ahead, 1074 behind
13 files changed+659−124
since splitsnapshots
unifiedsplit
bench/RunAll.hs+88 default.nix+3−3 reflex.cabal+3−3 src/Data/Functor/Misc.hs+26−25 src/Reflex/Class.hs+20−16 src/Reflex/Dynamic.hs+22−17 src/Reflex/Host/Class.hs+5−4 src/Reflex/Spider/Internal.hs+53−50 test/Reflex/Bench/Focused.hs+267 test/Reflex/Plan/Reflex.hs+121 test/Reflex/Pure.hs+4−4 test/Reflex/Test/CrossImpl.hs+2−2 test/Reflex/TestPlan.hs+45
bench/RunAll.hsnew file+88
@@ -0,0 +1,88 @@
1+{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module Main where
5+
6+import Criterion.Main
7+import Criterion.Types
8+
9+import Reflex
10+import Reflex.Host.Class
11+
12+import Reflex.TestPlan
13+import Reflex.Plan.Reflex
14+
15+import Reflex.Spider.Internal (SpiderEventHandle)
16+import qualified Reflex.Bench.Focused as Focused
17+
18+import Control.Applicative
19+import Control.DeepSeq (NFData (..))
20+
21+import System.IO
22+import System.Mem
23+import Prelude
24+
25+type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))
26+
27+
28+setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (Ignore (EventHandle t a), Schedule t)
29+setupFiring p = do
30+ (e, s) <- runPlan p
31+ h <- subscribeEvent e
32+ return (Ignore h, s)
33+
34+-- Hack to avoid the NFData constraint for EventHandle which is a synonym
35+newtype Ignore a = Ignore a
36+instance NFData (Ignore a) where
37+ rnf !_ = ()
38+
39+instance NFData (SpiderEventHandle a) where
40+ rnf !_ = ()
41+
42+instance NFData (Behavior t a) where
43+ rnf !_ = ()
44+
45+instance NFData (Firing t) where
46+ rnf !(Firing _ _) = ()
47+
48+-- Measure the running time
49+benchFiring :: (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> (String, TestCase) -> Benchmark
50+benchFiring runHost (name, TestE p) = env setup (\e -> bench name $ whnfIO $ run e) where
51+ run (Ignore h, s) = runHost (readSchedule s (readEvent' h)) >> performGC
52+ setup = runHost $ setupFiring p
53+
54+benchFiring runHost (name, TestB p) = env setup (\e -> bench name $ whnfIO $ run e) where
55+ run (b, s) = runHost (readSchedule s (sample b)) >> performGC
56+ setup = runHost $ do
57+ (b, s) <- runPlan p
58+ return (b, makeDense s)
59+
60+main :: IO ()
61+main = do
62+ hSetBuffering stdout LineBuffering
63+ defaultMainWith (defaultConfig { timeLimit = 10, csvFile = Just "dmap-new.csv" })
64+ [ benchImpl "spider" runSpiderHost
65+ ]
66+
67+benchImpl :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> Benchmark
68+benchImpl name runHost = bgroup name
69+ [ sub 100 40
70+ , dynamics 100
71+ , dynamics 1000
72+ , firing 1000
73+ , firing 10000
74+ , merging 10
75+ , merging 50
76+ , merging 100
77+ , merging 200
78+ ]
79+ where
80+ sub n frames = runGroup ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames
81+ firing n = runGroup ("firing " ++ show n) $ Focused.firing n
82+ merging n = runGroup ("merging " ++ show n) $ Focused.merging n
83+ dynamics n = runGroup ("dynamics " ++ show n) $ Focused.dynamics n
84+
85+ runGroup name' benchmarks = bgroup name' (benchFiring runHost <$> benchmarks)
86+
87+
88+
default.nix+3−3
@@ -1,17 +1,17 @@
11{ mkDerivation, dependent-map, dependent-sum
22, mtl, ref-tf, semigroups, these, MemoTrie, exception-transformers
3−, haskell-src-exts, haskell-src-meta
3+, haskell-src-exts, haskell-src-meta, criterion, split
44}:
55mkDerivation {
66 pname = "reflex";
7− version = "0.3.2";
7+ version = "0.4.0";
88 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
99 buildDepends = [
1010 dependent-map dependent-sum mtl ref-tf semigroups these exception-transformers
1111 haskell-src-exts haskell-src-meta
1212 ];
1313 testDepends = [
14− MemoTrie
14+ MemoTrie criterion split
1515 ];
1616 license = null;
1717}
reflex.cabal+3−3
@@ -1,5 +1,5 @@
11Name: reflex
2−Version: 0.3.2
2+Version: 0.4.0
33Synopsis: Higher-order Functional Reactive Programming
44Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
55License: BSD3
@@ -17,8 +17,8 @@ library
1717 hs-source-dirs: src
1818 build-depends:
1919 base >= 4.7 && < 4.9,
20− dependent-sum == 0.2.*,
21− dependent-map == 0.1.*,
20+ dependent-sum == 0.3.*,
21+ dependent-map == 0.2.*,
2222 semigroups >= 0.16 && < 0.18,
2323 mtl >= 2.1 && < 2.3,
2424 containers == 0.5.*,
src/Data/Functor/Misc.hs+26−25
@@ -8,7 +8,7 @@ import Data.Dependent.Map (DMap, DSum (..))
88import qualified Data.Dependent.Map as DMap
99import Data.Typeable hiding (Refl)
1010import Data.These
11−import Data.Maybe
11+import Control.Monad.Identity
1212
1313data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
1414 WrapArg :: f a -> WrapArg g f (g a)
@@ -39,37 +39,38 @@ instance Ord k => GCompare (Const2 k v) where
3939 GT -> GGT
4040
4141{-# INLINE sequenceDmap #-}
42−sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)
43−sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)
42+sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)
43+sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)
44+ (return DMap.empty)
4445
4546{-# INLINE combineDMapsWithKey #-}
46−combineDMapsWithKey :: forall f g h i. GCompare f => (forall a. f a -> These (g a) (h a) -> i a) -> DMap (WrapArg g f) -> DMap (WrapArg h f) -> DMap (WrapArg i f)
47+combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i
4748combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
48− where go :: [DSum (WrapArg g f)] -> [DSum (WrapArg h f)] -> [DSum (WrapArg i f)]
49− go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs
50− go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs
51− go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of
52− GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs
53− GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'
54− GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'
49+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
50+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
51+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
52+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
53+ GLT -> (gk :=> f gk (This gv)) : go gs' hs
54+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
55+ GGT -> (hk :=> f hk (That hv)) : go gs hs'
5556
56−wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)
57−wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList
57+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
58+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList
5859
59−rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)
60−rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList
60+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
61+rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList
6162
62−unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k
63−unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList
63+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
64+unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList
6465
65−unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k
66−unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList
66+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
67+unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]
6768
68−mapToDMap :: Map k v -> DMap (Const2 k v)
69−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
69+mapToDMap :: Map k v -> DMap (Const2 k v) Identity
70+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
7071
71−mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))
72−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList
72+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
73+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList
7374
74−dmapToMap :: DMap (Const2 k v) -> Map k v
75−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList
75+dmapToMap :: DMap (Const2 k v) Identity -> Map k v
76+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Reflex/Class.hs+20−16
@@ -45,9 +45,9 @@ class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Funct
4545 -- | A monad for doing complex pull-based calculations efficiently
4646 type PullM t :: * -> *
4747 -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously
48− merge :: GCompare k => DMap (WrapArg (Event t) k) -> Event t (DMap k) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
48+ merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
4949 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
50− fan :: GCompare k => Event t (DMap k) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
50+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
5151 -- | Create an Event that will occur whenever the currently-selected input Event occurs
5252 switch :: Behavior t (Event t a) -> Event t a
5353 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
@@ -273,30 +273,30 @@ instance GShow (EitherTag l r) where
273273 LeftTag -> showString "LeftTag"
274274 RightTag -> showString "RightTag"
275275
276−instance (Show l, Show r) => ShowTag (EitherTag l r) where
277− showTaggedPrec t n a = case t of
276+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
277+ showTaggedPrec t n (Identity a) = case t of
278278 LeftTag -> showsPrec n a
279279 RightTag -> showsPrec n a
280280
281281-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
282−eitherToDSum :: Either a b -> DSum (EitherTag a b)
282+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
283283eitherToDSum = \case
284− Left a -> LeftTag :=> a
285− Right b -> RightTag :=> b
284+ Left a -> (LeftTag :=> Identity a)
285+ Right b -> (RightTag :=> Identity b)
286286
287287-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
288−dsumToEither :: DSum (EitherTag a b) -> Either a b
288+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
289289dsumToEither = \case
290− LeftTag :=> a -> Left a
291− RightTag :=> b -> Right b
290+ (LeftTag :=> Identity a) -> Left a
291+ (RightTag :=> Identity b) -> Right b
292292
293293-- | Extract the values of a 'DMap' of 'EitherTag's.
294−dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
294+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
295295dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
296296 (Nothing, Nothing) -> Nothing
297− (Just a, Nothing) -> Just $ This a
298− (Nothing, Just b) -> Just $ That b
299− (Just a, Just b) -> Just $ These a b
297+ (Just (Identity a), Nothing) -> Just $ This a
298+ (Nothing, Just (Identity b)) -> Just $ That b
299+ (Just (Identity a), Just (Identity b)) -> Just $ These a b
300300
301301-- | Create a new 'Event' that occurs if at least one of the supplied
302302-- 'Event's occurs. If both occur at the same time they are combined
@@ -320,7 +320,11 @@ instance (Semigroup a, Reflex t) => Monoid (Event t a) where
320320-- in the list occurs. If multiple occur at the same time they are
321321-- folded from the left with the given function.
322322mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
323−mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
323+mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
324+ . merge
325+ . DMap.fromDistinctAscList
326+ . map (\(k, v) -> (Const2 k) :=> v)
327+ $ zip [0 :: Int ..] es
324328
325329-- | Create a new 'Event' that occurs if at least one of the 'Event's
326330-- in the list occurs. If multiple occur at the same time the value is
@@ -356,7 +360,7 @@ switchPromptly ea0 eea = do
356360
357361instance Reflex t => Align (Event t) where
358362 nil = never
359− align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
363+ align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
360364
361365-- | Create a new 'Event' that only occurs if the supplied 'Event'
362366-- occurs and the 'Behavior' is true at the time of occurence.
src/Reflex/Dynamic.hs+22−17
@@ -222,26 +222,26 @@ splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
222222-- | Merge the 'Dynamic' values using their 'Monoid' instance.
223223mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
224224mconcatDyn es = do
225− ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
226− mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
225+ ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es
226+ mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm
227227
228228-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
229229-- Dynamic values.
230−distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
230+distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
231231distributeDMapOverDyn dm = case DMap.toList dm of
232232 [] -> return $ constDyn DMap.empty
233− [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v
233+ [k :=> v] -> mapDyn (DMap.singleton k . Identity) v
234234 _ -> do
235235 let edmPre = merge $ rewrapDMap updated dm
236− edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do
236+ edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do
237237 let f _ = \case
238238 This origDyn -> sample $ current origDyn
239239 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
240240 These _ (Identity newVal) -> return newVal
241241 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
242− dm0 :: Behavior t (DMap k) = pull $ do
243− liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv
244− bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm
242+ dm0 :: Behavior t (DMap k Identity) = pull $ do
243+ liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv
244+ bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm
245245 let bdm = pull $ sample =<< sample bbdm
246246 return $ Dynamic bdm edm
247247
@@ -379,7 +379,12 @@ data Demux t k = Demux { demuxValue :: Behavior t k
379379
380380-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.
381381demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
382−demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))
382+demux k = Demux (current k)
383+ (fan $ attachWith (\k0 k1 -> if k0 == k1
384+ then DMap.empty
385+ else DMap.fromList [Const2 k0 :=> Identity False,
386+ Const2 k1 :=> Identity True])
387+ (current k) (updated k))
383388
384389--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
385390-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
@@ -417,16 +422,16 @@ data HListPtr l a where
417422 HHeadPtr :: HListPtr (h ': t) h
418423 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
419424
420−fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))
425+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
421426fhlistToDMap = DMap.fromList . go
422− where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]
427+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
423428 go = \case
424429 FHNil -> []
425− FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)
430+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t)
426431
427432class RebuildSortedHList l where
428− rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l
429− rebuildSortedHList :: [DSum (HListPtr l)] -> HList l
433+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
434+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
430435
431436instance RebuildSortedHList '[] where
432437 rebuildSortedFHList l = case l of
@@ -438,13 +443,13 @@ instance RebuildSortedHList '[] where
438443
439444instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
440445 rebuildSortedFHList l = case l of
441− ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
446+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
442447 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
443448 rebuildSortedHList l = case l of
444− ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
449+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
445450 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
446451
447−dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l
452+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
448453dmapToHList = rebuildSortedHList . DMap.toList
449454
450455distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
src/Reflex/Host/Class.hs+5−4
@@ -6,6 +6,7 @@ import Reflex.Class
66import Control.Applicative
77import Control.Monad
88import Control.Monad.Fix
9+import Control.Monad.Identity
910import Control.Monad.Trans
1011import Control.Monad.Trans.Reader (ReaderT())
1112import Control.Monad.Trans.Writer (WriterT())
@@ -84,7 +85,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona
8485 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)
8586 -- and then fires the corresponding events using this function. The read callback can be used
8687 -- to read output events and perform a corresponding response action to the external event.
87− fireEventsAndRead :: [DSum (EventTrigger t)] -> (ReadPhase m a) -> m a
88+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a
8889
8990 -- | Run a frame without any events firing.
9091 --
@@ -96,7 +97,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona
9697 runHostFrame :: HostFrame t a -> m a
9798
9899-- | Like 'fireEventsAndRead', but without reading any events.
99−fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()
100+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
100101fireEvents dm = fireEventsAndRead dm $ return ()
101102{-# INLINE fireEvents #-}
102103
@@ -120,14 +121,14 @@ fireEventRef mtRef input = do
120121 mt <- readRef mtRef
121122 case mt of
122123 Nothing -> return ()
123− Just trigger -> fireEvents [trigger :=> input]
124+ Just trigger -> fireEvents [trigger :=> Identity input]
124125
125126fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
126127fireEventRefAndRead mtRef input e = do
127128 mt <- readRef mtRef
128129 case mt of
129130 Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
130− Just trigger -> fireEventsAndRead [trigger :=> input] $ do
131+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
131132 mGetValue <- readEvent e
132133 case mGetValue of
133134 Nothing -> return Nothing
src/Reflex/Spider/Internal.hs+53−50
@@ -9,19 +9,20 @@ import System.Mem.Weak
99import Data.Foldable
1010import Data.Traversable
1111import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
12+import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
1213import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
1314import GHC.Exts
1415import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
1516import Data.Dependent.Map (DMap, DSum (..))
1617import qualified Data.Dependent.Map as DMap
1718import Data.GADT.Compare
18−import Data.Functor.Misc
1919import Data.Maybe
2020import Data.IntMap (IntMap)
2121import qualified Data.IntMap as IntMap
2222import Control.Monad.Ref
2323import Control.Monad.Exception
2424import Data.Monoid ((<>))
25+import Data.Coerce
2526
2627import System.IO.Unsafe
2728import Unsafe.Coerce
@@ -139,7 +140,7 @@ scheduleClear r = EventM $ do
139140 clears <- asks eventEnvClears
140141 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
141142
142−scheduleRootClear :: IORef (DMap k) -> EventM ()
143+scheduleRootClear :: IORef (DMap k Identity) -> EventM ()
143144scheduleRootClear r = EventM $ do
144145 clears <- asks eventEnvRootClears
145146 liftIO $ modifyIORef' clears (SomeDMapIORef r :)
@@ -223,8 +224,8 @@ data RootSubscribed a
223224 }
224225
225226data Root (k :: * -> *)
226− = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event
227− , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))
227+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
228+ , rootSubscribed :: !(IORef (DMap k RootSubscribed))
228229 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
229230 }
230231
@@ -251,12 +252,12 @@ data Push a b
251252 }
252253
253254data MergeSubscribed k
254− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))
255− , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
255+ = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
256+ , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
256257 , mergeSubscribedHeight :: !(IORef Int)
257− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])
258+ , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])
258259 , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory
259− , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))
260+ , mergeSubscribedParents :: !(DMap k EventSubscribed)
260261#ifdef DEBUG_NODEIDS
261262 , mergeSubscribedNodeId :: Int
262263#endif
@@ -264,7 +265,7 @@ data MergeSubscribed k
264265
265266--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
266267data Merge k
267− = Merge { mergeParents :: !(DMap (WrapArg Event k))
268+ = Merge { mergeParents :: !(DMap k Event)
268269 , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
269270 }
270271
@@ -283,16 +284,16 @@ instance GCompare k => GCompare (FanSubscriberKey k) where
283284 GGT -> GGT
284285
285286data FanSubscribed k
286− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))
287− , fanSubscribedParent :: !(EventSubscribed (DMap k))
288− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))
287+ = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))
288+ , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))
289+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))
289290#ifdef DEBUG_NODEIDS
290291 , fanSubscribedNodeId :: Int
291292#endif
292293 }
293294
294295data Fan k
295− = Fan { fanParent :: !(Event (DMap k))
296+ = Fan { fanParent :: !(Event (DMap k Identity))
296297 , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
297298 }
298299
@@ -354,7 +355,7 @@ deRefWeakSubscriber ws = case ws of
354355data Subscriber a
355356 = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)
356357 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
357− | forall k. (GCompare k, a ~ DMap k) => SubscriberFan (FanSubscribed k)
358+ | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
358359 | SubscriberHold !(Hold a)
359360 | SubscriberSwitch (SwitchSubscribed a)
360361 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
@@ -374,7 +375,7 @@ data Event a
374375 = forall k. GCompare k => EventRoot !(k a) !(Root k)
375376 | EventNever
376377 | forall b. EventPush !(Push b a)
377− | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)
378+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
378379 | forall k. GCompare k => EventFan !(k a) !(Fan k)
379380 | EventSwitch !(Switch a)
380381 | EventCoincidence !(Coincidence a)
@@ -393,7 +394,7 @@ data EventSubscribed a
393394 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
394395 | EventSubscribedNever
395396 | forall b. EventSubscribedPush !(PushSubscribed b a)
396− | forall k. (GCompare k, a ~ DMap k) => EventSubscribedMerge !(MergeSubscribed k)
397+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
397398 | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
398399 | EventSubscribedSwitch !(SwitchSubscribed a)
399400 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
@@ -424,7 +425,7 @@ newSubscriberHold :: Hold a -> IO (Subscriber a)
424425newSubscriberHold h = return $! SubscriberHold h
425426
426427{-# NOINLINE newSubscriberFan #-}
427−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))
428+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
428429newSubscriberFan subd = return $! SubscriberFan subd
429430
430431{-# NOINLINE newSubscriberSwitch #-}
@@ -519,7 +520,7 @@ propagateAndUpdateSubscribersRef subscribersRef a = do
519520 liftIO $ modifyIORef' subscribersRef (++stillAlive)
520521
521522-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
522−run :: [DSum RootTrigger] -> ResultM b -> IO b
523+run :: [DSum RootTrigger Identity] -> ResultM b -> IO b
523524run roots after = do
524525 when debugPropagate $ putStrLn "Running an event frame"
525526 result <- runFrame $ do
@@ -532,7 +533,7 @@ run roots after = do
532533 then do scheduleRootClear occRef
533534 return $ Just r
534535 else return Nothing
535− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do
536+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
536537 propagateAndUpdateSubscribersRef subscribersRef a
537538 delayedRef <- EventM $ asks eventEnvDelayedMerges
538539 let go = do
@@ -565,7 +566,7 @@ run roots after = do
565566
566567data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
567568
568−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))
569+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))
569570
570571data SomeAssignment = forall a. SomeAssignment (Hold a) a
571572
@@ -599,7 +600,7 @@ traverseAndCleanWeakList_ deRef ws f = go ws
599600propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
600601propagate a subscribers = do
601602 traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
602− SubscriberPush compute subscribed -> do
603+ SubscriberPush compute subscribed -> {-# SCC "pg->SubscriberPush" #-} do
603604 when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
604605 occ <- compute a
605606 case occ of
@@ -608,44 +609,46 @@ propagate a subscribers = do
608609 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
609610 scheduleClear $ pushSubscribedOccurrence subscribed
610611 liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
611− SubscriberMerge k subscribed -> do
612+ SubscriberMerge k subscribed -> {-# SCC "pg->SubscriberMerge" #-} do
612613 when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
613614 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
614− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM
615+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ {-# SCC "pg->sm->insertWith" #-} DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM
615616 when (DMap.null oldM) $ do -- Only schedule the firing once
616617 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
617618 --TODO: assertions about height
618− currentHeight <- getCurrentHeight
619+ currentHeight <- {-# SCC "getCurrentHeight" #-} getCurrentHeight
619620 when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
620− scheduleMerge height subscribed
621− SubscriberFan subscribed -> do
621+ {-# SCC "scheduleMerge" #-} scheduleMerge height subscribed
622+ SubscriberFan subscribed -> {-# SCC "pg->SubscriberFan" #-} do
622623 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
623624 when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
624625 --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
625− forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of
626+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of
626627 Nothing -> do
627628 when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
628629 return ()
629− Just subsubs -> do
630+ Just (Identity subsubs) -> do
630631 _ <- propagate v subsubs --TODO: use the value of this
631632 return ()
632633 --TODO: The following is way too slow to do all the time
633− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do
634+ subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do
634635 subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
635− return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))
636+ return $ if null subsubs'
637+ then Nothing
638+ else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))
636639 liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
637− SubscriberHold h -> do
640+ SubscriberHold h -> {-# SCC "pg->SubscriberHold" #-} do
638641 invalidators <- liftIO $ readIORef $ holdInvalidators h
639642 when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
640643 toAssignRef <- askToAssignRef
641644 liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
642− SubscriberSwitch subscribed -> do
645+ SubscriberSwitch subscribed -> {-# SCC "pg->SubscriberSwitch" #-} do
643646 when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
644647 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
645648 scheduleClear $ switchSubscribedOccurrence subscribed
646649 subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
647650 liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
648− SubscriberCoincidenceOuter subscribed -> do
651+ SubscriberCoincidenceOuter subscribed -> {-# SCC "pg->SubscriberCoincidenceOuter" #-} do
649652 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
650653 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
651654 when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
@@ -664,7 +667,7 @@ propagate a subscribers = do
664667 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
665668 scheduleClear $ coincidenceSubscribedOccurrence subscribed
666669 liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
667− SubscriberCoincidenceInner subscribed -> do
670+ SubscriberCoincidenceInner subscribed -> {-# SCC "pg->SubscriberCoincidenceInner" #-} do
668671 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
669672 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
670673 scheduleClear $ coincidenceSubscribedOccurrence subscribed
@@ -731,7 +734,7 @@ readBehaviorTracked b = case b of
731734
732735readEvent :: Event a -> ResultM (Maybe a)
733736readEvent e = case e of
734− EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r
737+ EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
735738 EventNever -> return Nothing
736739 EventPush p -> do
737740 subscribed <- getPushSubscribed p
@@ -747,7 +750,7 @@ readEvent e = case e of
747750 return result
748751 EventFan k f -> do
749752 parentOcc <- readEvent $ fanParent f
750− return $ DMap.lookup k =<< parentOcc
753+ return . coerce $ DMap.lookup k =<< parentOcc
751754 EventSwitch s -> do
752755 subscribed <- getSwitchSubscribed s
753756 liftIO $ do
@@ -794,7 +797,7 @@ subscribeEventSubscribed es ws = case es of
794797 modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
795798 EventSubscribedFan k subscribed -> do
796799 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
797− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]
800+ modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])
798801 EventSubscribedMerge subscribed -> do
799802 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
800803 modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
@@ -812,7 +815,7 @@ getEventSubscribedOcc es = case es of
812815 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
813816 EventSubscribedFan k subscribed -> do
814817 parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
815− let occ = DMap.lookup k =<< parentOcc
818+ let occ = coerce $ DMap.lookup k =<< parentOcc
816819 return occ
817820 EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
818821 EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
@@ -841,18 +844,18 @@ noinlineFalse = False
841844getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
842845getRootSubscribed k r = do
843846 mSubscribed <- liftIO $ readIORef $ rootSubscribed r
844− case DMap.lookup (WrapArg k) mSubscribed of
847+ case DMap.lookup k mSubscribed of
845848 Just subscribed -> return subscribed
846849 Nothing -> liftIO $ do
847850 subscribersRef <- newIORef []
848− subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
851+ subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
849852 -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
850853 uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
851854 addFinalizer subscribed $ do
852855 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
853856-- putStrLn "Uninit root"
854857 uninit
855− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed
858+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed
856859 return subscribed
857860
858861-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
@@ -894,11 +897,11 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
894897 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
895898 s <- liftIO $ newBox subscribedUnsafe
896899 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
897− subscribers :: [(Any, Maybe (DSum k), Int, DSum (WrapArg EventSubscribed k))] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(WrapArg k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
900+ subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
898901 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
899902 parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
900903 height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
901− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)
904+ return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd)
902905 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers
903906 subscriberHeights = map (\(_, _, x, _) -> x) subscribers
904907 myHeight =
@@ -1048,7 +1051,7 @@ getCoincidenceSubscribed c = do
10481051 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
10491052 return subscribed
10501053
1051−merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
1054+merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
10521055merge m = EventMerge $ Merge
10531056 { mergeParents = m
10541057 , mergeSubscribed = unsafeNewIORef m Nothing
@@ -1056,7 +1059,7 @@ merge m = EventMerge $ Merge
10561059
10571060newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
10581061
1059−fan :: GCompare k => Event (DMap k) -> EventSelector k
1062+fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
10601063fan e =
10611064 let f = Fan
10621065 { fanParent = e
@@ -1154,7 +1157,7 @@ invalidateSubscriberHeight ws = do
11541157 SubscriberFan subscribed -> do
11551158 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
11561159 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1157− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())
1160+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
11581161 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
11591162 SubscriberHold _ -> return ()
11601163 SubscriberSwitch subscribed -> do
@@ -1205,7 +1208,7 @@ recalculateSubscriberHeight ws = do
12051208 SubscriberFan subscribed -> do
12061209 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
12071210 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1208− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())
1211+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
12091212 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
12101213 SubscriberHold _ -> return ()
12111214 SubscriberSwitch subscribed -> do
@@ -1237,7 +1240,7 @@ recalculateCoincidenceHeight subscribed = do
12371240
12381241calculateMergeHeight :: MergeSubscribed k -> IO Int
12391242calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1240− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do
1243+ heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do
12411244 readIORef $ eventSubscribedHeightRef es
12421245 return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
12431246
@@ -1316,7 +1319,7 @@ instance R.Reflex Spider where
13161319 constant = SpiderBehavior . BehaviorConst
13171320 push f = SpiderEvent. push f . unSpiderEvent
13181321 pull = SpiderBehavior . pull
1319− merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))
1322+ merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)
13201323 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
13211324 switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
13221325 coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
@@ -1340,7 +1343,7 @@ instance R.MonadHold Spider EventM where
13401343 {-# INLINE hold #-}
13411344 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
13421345
1343−data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)
1346+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)
13441347newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
13451348
13461349instance R.MonadSubscribeEvent Spider SpiderHostFrame where
test/Reflex/Bench/Focused.hsnew file+267
@@ -0,0 +1,267 @@
1+{-# LANGUAGE RecursiveDo, ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Reflex.Bench.Focused where
4+
5+import Reflex
6+import Reflex.TestPlan
7+
8+import Control.Monad.Fix
9+import Control.Monad
10+import Control.Applicative
11+import Data.Foldable
12+import Data.Traversable
13+
14+import Data.Maybe
15+import Data.Map (Map)
16+import qualified Data.Map as Map
17+
18+import Data.Tuple
19+import Data.List
20+import Data.List.Split
21+
22+import Prelude
23+
24+mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
25+mergeTree n es | length es <= n = sum' es
26+ | otherwise = mergeTree n subTrees
27+ where
28+ merges = chunksOf n es
29+ subTrees = map sum' merges
30+ sum' = fmap sum . mconcat . fmap (fmap (:[]) )
31+
32+mergeListDyn :: (Reflex t, MonadHold t m) => [Dynamic t a] -> m (Dynamic t [a])
33+mergeListDyn dyns = traverse (mapDyn pure) dyns >>= mconcatDyn
34+
35+mergeTreeDyn :: (Num a, Reflex t, MonadHold t m, MonadFix m) => Int -> [Dynamic t a] -> m (Dynamic t a)
36+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
37+ | otherwise = traverse sumDyns merges >>= mergeTreeDyn n
38+ where
39+ merges = chunksOf n dyns
40+ sumDyns ds = mergeListDyn ds >>= mapDyn sum
41+
42+-- N events all firing for N frames
43+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
44+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
45+
46+-- Fire N events once every P frames for total N frames (interspersed evenly)
47+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
48+occasional n period frames = traverse plan $ zipWith occs [1..] phases
49+ where
50+ phases = take (fromIntegral n) $ concat (repeat [1..period])
51+ occs i phase = (, i) <$> [1, phase+1..frames]
52+
53+-- Event which never fires (but isn't 'never')
54+never' :: TestPlan t m => m (Event t Word)
55+never' = plan []
56+
57+-- Event which fires once on first frame
58+event :: TestPlan t m => m (Event t Word)
59+event = plan [(1, 0)]
60+
61+-- Event which fires constantly over N frames
62+events :: TestPlan t m => Word -> m (Event t Word)
63+events n = plan $ (\i -> (i, i)) <$> [1..n]
64+
65+-- N events all originating from one event
66+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
67+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
68+
69+-- Create an Event with a Map which is dense to size N
70+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
71+denseMap n = plan [(1, m)] where
72+ m = Map.fromList $ zip [1..n] [1..n]
73+
74+fmapChain :: Reflex t => Word -> Event t Word -> (Event t Word)
75+fmapChain 0 e = e
76+fmapChain n e = fmapChain (n - 1) (fmap (+1) e)
77+
78+mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
79+mapDynChain 0 d = return d
80+mapDynChain n d = mapDynChain (n - 1) =<< mapDyn (+1) d
81+
82+joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
83+joinDynChain 0 d = return d
84+joinDynChain n d = joinDynChain (n - 1) =<< joinDyn <$> mapDyn (const d) d
85+
86+combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
87+combineDynChain 0 d = return d
88+combineDynChain n d = combineDynChain (n - 1) =<< combineDyn (+) d d
89+
90+pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
91+pingPong e1 e2 = do
92+ rec
93+ d <- foldDyn (const swap) (e1, e2) e
94+ let e = switch (fst <$> current d)
95+ return e
96+
97+switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
98+switchFactors 0 e = return e
99+switchFactors i e = do
100+ b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
101+ switchFactors (i - 1) (switch b)
102+
103+switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
104+switchChain 0 e = return e
105+switchChain i e = switchChain (i - 1) =<< pingPong e ((+1) <$> e)
106+
107+switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
108+switchChain2 0 e = return e
109+switchChain2 i e = switchChain2 (i - 1) =<< pingPong e ((+1) <$> leftmost [e, e])
110+
111+switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
112+switchPromptlyChain 0 e = return e
113+switchPromptlyChain i e = do
114+ d <- holdDyn e (e <$ e)
115+ switchPromptlyChain (i - 1) (switchPromptlyDyn d)
116+
117+coinChain :: Reflex t => Word -> Event t Word -> Event t Word
118+coinChain 0 e = e
119+coinChain n e = coinChain (n - 1) $ coincidence (e <$ e)
120+
121+pullChain :: Reflex t => Word -> Behavior t Word -> Behavior t Word
122+pullChain 0 b = b
123+pullChain n b = pullChain (n - 1) $ (+1) <$> b
124+
125+-- | Data type for a collection (a map) which is updated by providing differences
126+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
127+
128+-- This will hopefully become a primitive (faster!)
129+switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
130+switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
131+
132+switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))
133+switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges
134+ where joinMap m = traverse sample =<< sample m
135+
136+-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
137+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
138+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
139+ where
140+ modify k Nothing items = Map.delete k items
141+ modify k (Just item) items = Map.insert k item items
142+
143+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
144+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
145+holdMap = (current <$>) . holdMapDyn
146+
147+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
148+increasingMerge xs = do
149+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
150+ return (UpdatedMap Map.empty e)
151+ where
152+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
153+
154+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
155+decreasingMerge xs = do
156+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
157+ return (UpdatedMap initial e)
158+ where
159+ initial = Map.fromList $ zip [1..] xs
160+ reset = Just <$> initial
161+
162+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
163+modifyMerge xs = do
164+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
165+ return (UpdatedMap initial e)
166+ where
167+ initial = Map.fromList $ zip [1..] xs
168+
169+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
170+countMany = traverse (fmap current . count)
171+
172+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
173+countManyDyn = traverse count
174+
175+-- Given a function which creates a sub-network (from a single event)
176+-- Create a plan which uses a switch to substitute it
177+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
178+switches numFrames f = do
179+ es <- events numFrames
180+ switch <$> hold never (makeEvents es)
181+ where
182+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
183+
184+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
185+-- the other, which we're only interested in time for running frames
186+subscribing :: Word -> Word -> [(String, TestCase)]
187+subscribing n frames =
188+ [ testE "fmapFan merge" $ switches frames (return . mergeList . fmapFan n)
189+ , testE "fmapFan/mergeTree" $ switches frames (return . mergeTree 8 . fmapFan n)
190+ , testE "fmapChain" $ switches frames (return . fmapChain n)
191+ , testE "switchChain" $ switches frames (switchChain n)
192+ , testE "switchPromptlyChain" $ switches frames (switchPromptlyChain n)
193+ , testE "switchFactors" $ switches frames (switchFactors n)
194+ , testE "coincidenceChain" $ switches frames (return . coinChain n)
195+ ]
196+
197+-- Set of benchmark to test specifically merging dynamic collections
198+-- a pattern which occurs frequently in reflex-dom collections
199+merging :: Word -> [(String, TestCase)]
200+merging n =
201+ [ testE "static events" $ mergeList <$> sparse
202+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
203+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
204+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
205+
206+ , testB "static behaviors" $ pull . traverse sample <$> counters
207+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
208+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
209+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
210+ ]
211+ where
212+ sparse :: TestPlan t m => m [Event t Word]
213+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
214+
215+ counters :: TestPlan t m => m [Behavior t Int]
216+ counters = countMany =<< sparse
217+
218+dynamics :: Word -> [(String, TestCase)]
219+dynamics n =
220+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
221+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
222+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
223+ , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense
224+ , testE "sparse mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< sparse
225+ , testE "mergeDyn" $ fmap updated $ mapDyn sum =<< mergeListDyn =<< sparse
226+ ] where
227+ d :: TestPlan t m => m (Dynamic t Word)
228+ d = count =<< events 10
229+
230+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
231+ sparse = countManyDyn =<< occasional n 8 16
232+ dense = countManyDyn =<< continuous n 2
233+
234+firing :: Word -> [(String, TestCase)]
235+firing n =
236+ [ testE "fmapChain" $ fmapChain n <$> e
237+ , testE "switchChain2" $ switchChain2 n =<< e
238+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
239+ , testE "switchFactors" $ switchFactors n =<< e
240+ , testE "coincidenceChain" $ coinChain n <$> e
241+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
242+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
243+ , testE "runFrame" $ events n
244+ , testB "sum counters" $ do
245+ counts <- counters
246+ return $ pull $ sum <$> traverse sample counts
247+
248+ , testB "pullChain" $ pullChain n . current <$> (count =<< events 4)
249+ , testB "pullChain2" $ do
250+ e' <- events 4
251+ b <- hold (constant 0) $ leftmost
252+ [ constant 0 <$ ffilter (==4) e'
253+ , pushAlways (const $ pullChain n <$> hold 0 e') e'
254+ ]
255+ return (join b)
256+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
257+ ]
258+ where
259+ e :: TestPlan t m => m (Event t Word)
260+ e = events 10
261+
262+ dense, sparse :: TestPlan t m => m [Event t Word]
263+ dense = continuous n 2
264+ sparse = occasional n 8 16
265+
266+ counters :: TestPlan t m => m [Behavior t Int]
267+ counters = countMany =<< sparse
test/Reflex/Plan/Reflex.hsnew file+121
@@ -0,0 +1,121 @@
1+{-# LANGUAGE FunctionalDependencies, BangPatterns, UndecidableInstances, ConstraintKinds, GADTs, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, RecursiveDo, FlexibleContexts, StandaloneDeriving #-}
2+module Reflex.Plan.Reflex
3+ ( TestPlan(..)
4+ , runPlan
5+ , Plan
6+ , Schedule
7+ , Firing (..)
8+ , MonadIORef
9+
10+
11+ , readSchedule
12+ , testSchedule
13+ , readEvent'
14+ , makeDense
15+
16+ , runTestE
17+ , runTestB
18+
19+ ) where
20+
21+import Reflex.Class
22+import Reflex.Host.Class
23+import Reflex.TestPlan
24+
25+import Control.Applicative
26+import Control.Monad
27+import Control.Monad.Identity
28+import Control.Monad.State.Strict
29+
30+import Data.Dependent.Sum (DSum (..))
31+import Data.Monoid
32+import Data.Maybe
33+import qualified Data.IntMap.Strict as IntMap
34+import Control.Monad.Ref
35+
36+
37+import Data.IntMap.Strict (IntMap)
38+import Data.IORef
39+import System.Mem
40+
41+-- Note: this import must come last to silence warnings from AMP
42+import Prelude
43+
44+type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
45+
46+data Firing t where
47+ Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
48+
49+
50+type Schedule t = IntMap [Firing t]
51+
52+-- Implementation of a TestPlan in terms of ReflexHost
53+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
54+
55+deriving instance ReflexHost t => Functor (Plan t)
56+deriving instance ReflexHost t => Applicative (Plan t)
57+deriving instance ReflexHost t => Monad (Plan t)
58+
59+deriving instance ReflexHost t => MonadSample t (Plan t)
60+deriving instance ReflexHost t => MonadHold t (Plan t)
61+deriving instance ReflexHost t => MonadFix (Plan t)
62+
63+
64+instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
65+ plan occurances = Plan $ do
66+ (e, ref) <- newEventWithTriggerRef
67+ modify (IntMap.unionWith mappend (firings ref))
68+ return e
69+
70+ where
71+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
72+ makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
73+
74+
75+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
76+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
77+
78+runPlan :: (MonadReflexHost t m, MonadIORef m) => Plan t a -> m (a, Schedule t)
79+runPlan (Plan p) = runHostFrame $ runStateT p mempty
80+
81+
82+makeDense :: Schedule t -> Schedule t
83+makeDense s = fromMaybe (emptyRange 0) $ do
84+ (end, _) <- fst <$> IntMap.maxViewWithKey s
85+ return $ IntMap.union s (emptyRange end)
86+ where
87+ emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
88+
89+
90+-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
91+-- after the last event)
92+-- performGC is called at each frame to test for GC issues
93+testSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
94+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
95+
96+readSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
97+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
98+
99+triggerFrame :: (MonadReflexHost t m, MonadIORef m) => ReadPhase m a -> Int -> [Firing t] -> m a
100+triggerFrame readResult _ occs = do
101+ triggers <- {-# SCC "catMaybes/traverse" #-} catMaybes <$> traverse firingTrigger occs
102+ {-# SCC fireEventsAndRead #-} fireEventsAndRead triggers readResult
103+
104+
105+readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
106+readEvent' = readEvent >=> sequence
107+
108+
109+-- Convenience functions for running tests producing Events/Behaviors
110+runTestB :: (MonadReflexHost t m, MonadIORef m) => Plan t (Behavior t a) -> m (IntMap a)
111+runTestB p = do
112+ (b, s) <- runPlan p
113+ testSchedule s $ sample b
114+
115+runTestE :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (IntMap (Maybe a))
116+runTestE p = do
117+ (e, s) <- runPlan p
118+ h <- subscribeEvent e
119+ testSchedule s (readEvent' h)
120+
121+
test/Reflex/Pure.hs+4−4
@@ -9,7 +9,7 @@ module Reflex.Pure where
99
1010import Reflex.Class
1111import Data.Functor.Misc
12−
12+import Control.Monad.Identity
1313import Control.Monad
1414import Data.MemoTrie
1515import Data.Dependent.Map (DMap, GCompare)
@@ -40,15 +40,15 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
4040 pull :: PullM (Pure t) a -> Behavior (Pure t) a
4141 pull = Behavior . memo
4242
43− merge :: GCompare k => DMap (WrapArg (Event (Pure t)) k) -> Event (Pure t) (DMap k)
43+ merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
4444 merge events = Event $ memo $ \t ->
4545 let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events
4646 in if DMap.null currentOccurrences
4747 then Nothing
4848 else Just currentOccurrences
4949
50− fan :: GCompare k => Event (Pure t) (DMap k) -> EventSelector (Pure t) k
51− fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
50+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
51+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
5252
5353 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
5454 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
test/Reflex/Test/CrossImpl.hs+2−2
@@ -71,12 +71,12 @@ testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
7171 let times = relevantTestingTimes (bMap, eMap)
7272 liftIO performGC
7373 outputs <- forM times $ \t -> do
74− forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger
74+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
7575 bOutput <- sample b'
7676 eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do
7777 mret <- readRef reTrigger
7878 let firing = case mret of
79− Just ret -> [ret :=> val]
79+ Just ret -> [ret :=> Identity val]
8080 Nothing -> []
8181 fireEventsAndRead firing $ sequence =<< readEvent e'Handle
8282 liftIO performGC
test/Reflex/TestPlan.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE FunctionalDependencies, BangPatterns, UndecidableInstances, ConstraintKinds, GADTs, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, RecursiveDo, FlexibleContexts, StandaloneDeriving #-}
2+module Reflex.TestPlan
3+ ( TestPlan(..)
4+
5+ , TestCase (..)
6+ , testE, testB
7+ , TestE, TestB
8+
9+ , planList
10+
11+ ) where
12+
13+import Reflex.Class
14+import Control.Monad.Fix
15+
16+import qualified Data.IntMap as IntMap
17+import Data.IntMap
18+
19+import Prelude
20+
21+class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where
22+ -- | Speicify a plan of an input Event firing
23+ -- Occurances must be in the future (i.e. Time > 0)
24+ -- Initial specification is
25+
26+ plan :: [(Word, a)] -> m (Event t a)
27+
28+
29+planList :: TestPlan t m => [a] -> m (Event t a)
30+planList xs = plan $ zip [1..] xs
31+
32+type TestE a = forall t m. TestPlan t m => m (Event t a)
33+type TestB a = forall t m. TestPlan t m => m (Behavior t a)
34+
35+data TestCase where
36+ TestE :: (Show a, Eq a) => TestE a -> TestCase
37+ TestB :: (Show a, Eq a) => TestB a -> TestCase
38+
39+-- Helpers to declare test cases
40+testE :: (Eq a, Show a) => String -> TestE a -> (String, TestCase)
41+testE name test = (name, TestE test)
42+
43+testB :: (Eq a, Show a) => String -> TestB a -> (String, TestCase)
44+testB name test = (name, TestB test)
45+