develop...8246ce1 · reflex

git.iko.soy/reflex

bench/RunAll.hsnew file+88

since splitsnapshots

@@ -0,0 +1,88 @@

1+{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

4+module Main where

6+import Criterion.Main

7+import Criterion.Types

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 @@

1{ mkDerivation, dependent-map, dependent-sum

2, mtl, ref-tf, semigroups, these, MemoTrie, exception-transformers

3−, haskell-src-exts, haskell-src-meta

3+, haskell-src-exts, haskell-src-meta, criterion, split

4}:

5mkDerivation {

6 pname = "reflex";

7− version = "0.3.2";

7+ version = "0.4.0";

8 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

9 buildDepends = [

10 dependent-map dependent-sum mtl ref-tf semigroups these exception-transformers

11 haskell-src-exts haskell-src-meta

12 ];

13 testDepends = [

14− MemoTrie

14+ MemoTrie criterion split

15 ];

16 license = null;

17}

reflex.cabal+3−3

@@ -1,5 +1,5 @@

1Name: reflex

2−Version: 0.3.2

2+Version: 0.4.0

3Synopsis: Higher-order Functional Reactive Programming

4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system

5License: BSD3

@@ -17,8 +17,8 @@ library

17 hs-source-dirs: src

18 build-depends:

19 base >= 4.7 && < 4.9,

20− dependent-sum == 0.2.*,

20+ dependent-sum == 0.3.*,

21− dependent-map == 0.1.*,

21+ dependent-map == 0.2.*,

22 semigroups >= 0.16 && < 0.18,

23 mtl >= 2.1 && < 2.3,

24 containers == 0.5.*,

src/Data/Functor/Misc.hs+26−25

@@ -8,7 +8,7 @@ import Data.Dependent.Map (DMap, DSum (..))

8import qualified Data.Dependent.Map as DMap

9import Data.Typeable hiding (Refl)

10import Data.These

11−import Data.Maybe

11+import Control.Monad.Identity

13data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

14 WrapArg :: f a -> WrapArg g f (g a)

@@ -39,37 +39,38 @@ instance Ord k => GCompare (Const2 k v) where

39 GT -> GGT

41{-# INLINE sequenceDmap #-}

42−sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)

42+sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)

43−sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)

43+sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)

44+ (return DMap.empty)

45{-# INLINE combineDMapsWithKey #-}

46{-# 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

47combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

48combineDMapsWithKey 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+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]

49− go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs

50+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs

50− go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs

51+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs

51− go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of

52+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of

52− GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs

53+ GLT -> (gk :=> f gk (This gv)) : go gs' hs

53− GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'

54+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

54− GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'

55+ GGT -> (hk :=> f hk (That hv)) : go gs hs'

56−wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)

57+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f

57−wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList

58+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList

59−rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)

60+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g

60−rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList

61+rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList

62−unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k

63+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity

63−unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList

64+unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList

65−unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k

66+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity

66−unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList

67+unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]

68−mapToDMap :: Map k v -> DMap (Const2 k v)

69+mapToDMap :: Map k v -> DMap (Const2 k v) Identity

69−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

70+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList

71−mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))

72+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

72−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList

73+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList

74−dmapToMap :: DMap (Const2 k v) -> Map k v

75+dmapToMap :: DMap (Const2 k v) Identity -> Map k v

75−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList

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

45 -- | A monad for doing complex pull-based calculations efficiently

46 type PullM t :: * -> *

47 -- | 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

49 -- | 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

51 -- | Create an Event that will occur whenever the currently-selected input Event occurs

52 switch :: Behavior t (Event t a) -> Event t a

53 -- | 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

273 LeftTag -> showString "LeftTag"

274 RightTag -> showString "RightTag"

275

276−instance (Show l, Show r) => ShowTag (EitherTag l r) where

276+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

277− showTaggedPrec t n a = case t of

277+ showTaggedPrec t n (Identity a) = case t of

278 LeftTag -> showsPrec n a

279 RightTag -> showsPrec n a

280

281-- | 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

283eitherToDSum = \case

284− Left a -> LeftTag :=> a

284+ Left a -> (LeftTag :=> Identity a)

285− Right b -> RightTag :=> b

285+ Right b -> (RightTag :=> Identity b)

286

287-- | 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

289dsumToEither = \case

290− LeftTag :=> a -> Left a

290+ (LeftTag :=> Identity a) -> Left a

291− RightTag :=> b -> Right b

291+ (RightTag :=> Identity b) -> Right b

292

293-- | 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)

295dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

296 (Nothing, Nothing) -> Nothing

297− (Just a, Nothing) -> Just $ This a

297+ (Just (Identity a), Nothing) -> Just $ This a

298− (Nothing, Just b) -> Just $ That b

298+ (Nothing, Just (Identity b)) -> Just $ That b

299− (Just a, Just b) -> Just $ These a b

299+ (Just (Identity a), Just (Identity b)) -> Just $ These a b

300

301-- | Create a new 'Event' that occurs if at least one of the supplied

302-- '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

320-- in the list occurs. If multiple occur at the same time they are

321-- folded from the left with the given function.

322mergeWith :: 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

324

328

325-- | Create a new 'Event' that occurs if at least one of the 'Event's

329-- | Create a new 'Event' that occurs if at least one of the 'Event's

326-- in the list occurs. If multiple occur at the same time the value is

330-- in the list occurs. If multiple occur at the same time the value is

@@ -356,7 +360,7 @@ switchPromptly ea0 eea = do

356

360

357instance Reflex t => Align (Event t) where

361instance Reflex t => Align (Event t) where

358 nil = never

362 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]

360

364

361-- | Create a new 'Event' that only occurs if the supplied 'Event'

365-- | Create a new 'Event' that only occurs if the supplied 'Event'

362-- occurs and the 'Behavior' is true at the time of occurence.

366-- 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)

222-- | Merge the 'Dynamic' values using their 'Monoid' instance.

223mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

224mconcatDyn es = do

225− ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es

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 _ :=> v) -> v) . DMap.toList) ddm

226+ mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm

227

228-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of

229-- 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))

231distributeDMapOverDyn dm = case DMap.toList dm of

232 [] -> return $ constDyn DMap.empty

233− [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v

233+ [k :=> v] -> mapDyn (DMap.singleton k . Identity) v

234 _ -> do

235 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

237 let f _ = \case

238 This origDyn -> sample $ current origDyn

239 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"

240 These _ (Identity newVal) -> return newVal

241 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)

242− dm0 :: Behavior t (DMap k) = pull $ do

242+ dm0 :: Behavior t (DMap k Identity) = pull $ do

243− liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv

243+ liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv

244− bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm

244+ bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm

245 let bdm = pull $ sample =<< sample bbdm

246 return $ Dynamic bdm edm

247

@@ -379,7 +379,12 @@ data Demux t k = Demux { demuxValue :: Behavior t k

379

380-- | 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'.

381demux :: (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))

383

388

384--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

389--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

385-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)

390-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)

@@ -417,16 +422,16 @@ data HListPtr l a where

417 HHeadPtr :: HListPtr (h ': t) h

422 HHeadPtr :: HListPtr (h ': t) h

418 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

423 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

419

424

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

421fhlistToDMap = DMap.fromList . go

426fhlistToDMap = 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]

423 go = \case

428 go = \case

424 FHNil -> []

429 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)

426

431

427class RebuildSortedHList l where

432class RebuildSortedHList l where

428− rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l

433+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l

429− rebuildSortedHList :: [DSum (HListPtr l)] -> HList l

434+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l

430

435

431instance RebuildSortedHList '[] where

436instance RebuildSortedHList '[] where

432 rebuildSortedFHList l = case l of

437 rebuildSortedFHList l = case l of

@@ -438,13 +443,13 @@ instance RebuildSortedHList '[] where

438

443

439instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

444instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

440 rebuildSortedFHList l = case l of

445 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

442 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"

447 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"

443 rebuildSortedHList l = case l of

448 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

445 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

450 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

446

451

447−dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l

452+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l

448dmapToHList = rebuildSortedHList . DMap.toList

453dmapToHList = rebuildSortedHList . DMap.toList

449

454

450distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

455distributeFHListOverDyn :: 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

6import Control.Applicative

7import Control.Monad

8import Control.Monad.Fix

9+import Control.Monad.Identity

9import Control.Monad.Trans

10import Control.Monad.Trans

10import Control.Monad.Trans.Reader (ReaderT())

11import Control.Monad.Trans.Reader (ReaderT())

11import Control.Monad.Trans.Writer (WriterT())

12import Control.Monad.Trans.Writer (WriterT())

@@ -84,7 +85,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona

84 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

85 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

85 -- and then fires the corresponding events using this function. The read callback can be used

86 -- and then fires the corresponding events using this function. The read callback can be used

86 -- to read output events and perform a corresponding response action to the external event.

87 -- 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

89 -- | Run a frame without any events firing.

90 -- | Run a frame without any events firing.

90 --

91 --

@@ -96,7 +97,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona

96 runHostFrame :: HostFrame t a -> m a

97 runHostFrame :: HostFrame t a -> m a

98-- | Like 'fireEventsAndRead', but without reading any events.

99-- | 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 ()

100fireEvents dm = fireEventsAndRead dm $ return ()

101fireEvents dm = fireEventsAndRead dm $ return ()

101{-# INLINE fireEvents #-}

102{-# INLINE fireEvents #-}

102

103

@@ -120,14 +121,14 @@ fireEventRef mtRef input = do

120 mt <- readRef mtRef

121 mt <- readRef mtRef

121 case mt of

122 case mt of

122 Nothing -> return ()

123 Nothing -> return ()

123− Just trigger -> fireEvents [trigger :=> input]

124+ Just trigger -> fireEvents [trigger :=> Identity input]

124

125

125fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)

126fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)

126fireEventRefAndRead mtRef input e = do

127fireEventRefAndRead mtRef input e = do

127 mt <- readRef mtRef

128 mt <- readRef mtRef

128 case mt of

129 case mt of

129 Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire

130 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

131 mGetValue <- readEvent e

132 mGetValue <- readEvent e

132 case mGetValue of

133 case mGetValue of

133 Nothing -> return Nothing

134 Nothing -> return Nothing

src/Reflex/Spider/Internal.hs+53−50

@@ -9,19 +9,20 @@ import System.Mem.Weak

9import Data.Foldable

10import Data.Traversable

11import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)

12+import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)

12import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

13import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

13import GHC.Exts

14import GHC.Exts

14import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2

15import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2

15import Data.Dependent.Map (DMap, DSum (..))

16import Data.Dependent.Map (DMap, DSum (..))

16import qualified Data.Dependent.Map as DMap

17import qualified Data.Dependent.Map as DMap

17import Data.GADT.Compare

18import Data.GADT.Compare

18−import Data.Functor.Misc

19import Data.Maybe

20import Data.IntMap (IntMap)

21import qualified Data.IntMap as IntMap

22import Control.Monad.Ref

23import Control.Monad.Exception

24import Data.Monoid ((<>))

25+import Data.Coerce

26import System.IO.Unsafe

27import System.IO.Unsafe

27import Unsafe.Coerce

28import Unsafe.Coerce

@@ -139,7 +140,7 @@ scheduleClear r = EventM $ do

139 clears <- asks eventEnvClears

140 clears <- asks eventEnvClears

140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

141 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

141

142

142−scheduleRootClear :: IORef (DMap k) -> EventM ()

143+scheduleRootClear :: IORef (DMap k Identity) -> EventM ()

143scheduleRootClear r = EventM $ do

144scheduleRootClear r = EventM $ do

144 clears <- asks eventEnvRootClears

145 clears <- asks eventEnvRootClears

145 liftIO $ modifyIORef' clears (SomeDMapIORef r :)

146 liftIO $ modifyIORef' clears (SomeDMapIORef r :)

@@ -223,8 +224,8 @@ data RootSubscribed a

223 }

224 }

224

225

225data Root (k :: * -> *)

226data Root (k :: * -> *)

226− = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event

227+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

227− , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))

228+ , rootSubscribed :: !(IORef (DMap k RootSubscribed))

228 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

229 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

229 }

230 }

230

231

@@ -251,12 +252,12 @@ data Push a b

251 }

252 }

252

253

253data MergeSubscribed k

254data MergeSubscribed k

254− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))

255+ = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

255− , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

256+ , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

256 , mergeSubscribedHeight :: !(IORef Int)

257 , mergeSubscribedHeight :: !(IORef Int)

257− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])

258+ , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])

258 , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory

259 , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory

259− , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))

260+ , mergeSubscribedParents :: !(DMap k EventSubscribed)

260#ifdef DEBUG_NODEIDS

261#ifdef DEBUG_NODEIDS

261 , mergeSubscribedNodeId :: Int

262 , mergeSubscribedNodeId :: Int

262#endif

263#endif

@@ -264,7 +265,7 @@ data MergeSubscribed k

264

265

265--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)

266--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)

266data Merge k

267data Merge k

267− = Merge { mergeParents :: !(DMap (WrapArg Event k))

268+ = Merge { mergeParents :: !(DMap k Event)

268 , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?

269 , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?

269 }

270 }

270

271

@@ -283,16 +284,16 @@ instance GCompare k => GCompare (FanSubscriberKey k) where

283 GGT -> GGT

284 GGT -> GGT

284

285

285data FanSubscribed k

286data FanSubscribed k

286− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))

287+ = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))

287− , fanSubscribedParent :: !(EventSubscribed (DMap k))

288+ , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))

288− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))

289+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))

289#ifdef DEBUG_NODEIDS

290#ifdef DEBUG_NODEIDS

290 , fanSubscribedNodeId :: Int

291 , fanSubscribedNodeId :: Int

291#endif

292#endif

292 }

293 }

293

294

294data Fan k

295data Fan k

295− = Fan { fanParent :: !(Event (DMap k))

296+ = Fan { fanParent :: !(Event (DMap k Identity))

296 , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))

297 , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))

297 }

298 }

298

299

@@ -354,7 +355,7 @@ deRefWeakSubscriber ws = case ws of

354data Subscriber a

355data Subscriber a

355 = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)

356 = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)

356 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?

357 | 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)

358 | SubscriberHold !(Hold a)

359 | SubscriberHold !(Hold a)

359 | SubscriberSwitch (SwitchSubscribed a)

360 | SubscriberSwitch (SwitchSubscribed a)

360 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)

361 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)

@@ -374,7 +375,7 @@ data Event a

374 = forall k. GCompare k => EventRoot !(k a) !(Root k)

375 = forall k. GCompare k => EventRoot !(k a) !(Root k)

375 | EventNever

376 | EventNever

376 | forall b. EventPush !(Push b a)

377 | 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)

378 | forall k. GCompare k => EventFan !(k a) !(Fan k)

379 | forall k. GCompare k => EventFan !(k a) !(Fan k)

379 | EventSwitch !(Switch a)

380 | EventSwitch !(Switch a)

380 | EventCoincidence !(Coincidence a)

381 | EventCoincidence !(Coincidence a)

@@ -393,7 +394,7 @@ data EventSubscribed a

393 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

394 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

394 | EventSubscribedNever

395 | EventSubscribedNever

395 | forall b. EventSubscribedPush !(PushSubscribed b a)

396 | 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)

397 | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)

398 | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)

398 | EventSubscribedSwitch !(SwitchSubscribed a)

399 | EventSubscribedSwitch !(SwitchSubscribed a)

399 | EventSubscribedCoincidence !(CoincidenceSubscribed a)

400 | EventSubscribedCoincidence !(CoincidenceSubscribed a)

@@ -424,7 +425,7 @@ newSubscriberHold :: Hold a -> IO (Subscriber a)

424newSubscriberHold h = return $! SubscriberHold h

425newSubscriberHold h = return $! SubscriberHold h

425

426

426{-# NOINLINE newSubscriberFan #-}

427{-# NOINLINE newSubscriberFan #-}

427−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))

428+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))

428newSubscriberFan subd = return $! SubscriberFan subd

429newSubscriberFan subd = return $! SubscriberFan subd

429

430

430{-# NOINLINE newSubscriberSwitch #-}

431{-# NOINLINE newSubscriberSwitch #-}

@@ -519,7 +520,7 @@ propagateAndUpdateSubscribersRef subscribersRef a = do

519 liftIO $ modifyIORef' subscribersRef (++stillAlive)

520 liftIO $ modifyIORef' subscribersRef (++stillAlive)

520

521

521-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

522-- 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

523run roots after = do

524run roots after = do

524 when debugPropagate $ putStrLn "Running an event frame"

525 when debugPropagate $ putStrLn "Running an event frame"

525 result <- runFrame $ do

526 result <- runFrame $ do

@@ -532,7 +533,7 @@ run roots after = do

532 then do scheduleRootClear occRef

533 then do scheduleRootClear occRef

533 return $ Just r

534 return $ Just r

534 else return Nothing

535 else return Nothing

535− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do

536+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do

536 propagateAndUpdateSubscribersRef subscribersRef a

537 propagateAndUpdateSubscribersRef subscribersRef a

537 delayedRef <- EventM $ asks eventEnvDelayedMerges

538 delayedRef <- EventM $ asks eventEnvDelayedMerges

538 let go = do

539 let go = do

@@ -565,7 +566,7 @@ run roots after = do

565

566

566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

567data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

567

568

568−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))

569+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))

569

570

570data SomeAssignment = forall a. SomeAssignment (Hold a) a

571data SomeAssignment = forall a. SomeAssignment (Hold a) a

571

572

@@ -599,7 +600,7 @@ traverseAndCleanWeakList_ deRef ws f = go ws

599propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]

600propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]

600propagate a subscribers = do

601propagate a subscribers = do

601 traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of

602 traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of

602− SubscriberPush compute subscribed -> do

603+ SubscriberPush compute subscribed -> {-# SCC "pg->SubscriberPush" #-} do

603 when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed

604 when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed

604 occ <- compute a

605 occ <- compute a

605 case occ of

606 case occ of

@@ -608,44 +609,46 @@ propagate a subscribers = do

608 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ

609 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ

609 scheduleClear $ pushSubscribedOccurrence subscribed

610 scheduleClear $ pushSubscribedOccurrence subscribed

610 liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))

611 liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))

611− SubscriberMerge k subscribed -> do

612+ SubscriberMerge k subscribed -> {-# SCC "pg->SubscriberMerge" #-} do

612 when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed

613 when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed

613 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed

614 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

615 when (DMap.null oldM) $ do -- Only schedule the firing once

616 when (DMap.null oldM) $ do -- Only schedule the firing once

616 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed

617 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed

617 --TODO: assertions about height

618 --TODO: assertions about height

618− currentHeight <- getCurrentHeight

619+ currentHeight <- {-# SCC "getCurrentHeight" #-} getCurrentHeight

619 when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"

620 when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"

620− scheduleMerge height subscribed

621+ {-# SCC "scheduleMerge" #-} scheduleMerge height subscribed

621− SubscriberFan subscribed -> do

622+ SubscriberFan subscribed -> {-# SCC "pg->SubscriberFan" #-} do

622 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

623 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

623 when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

624 when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

624 --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 --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

626 Nothing -> do

627 Nothing -> do

627 when debugPropagate $ liftIO $ putStrLn "No subscriber for key"

628 when debugPropagate $ liftIO $ putStrLn "No subscriber for key"

628 return ()

629 return ()

629− Just subsubs -> do

630+ Just (Identity subsubs) -> do

630 _ <- propagate v subsubs --TODO: use the value of this

631 _ <- propagate v subsubs --TODO: use the value of this

631 return ()

632 return ()

632 --TODO: The following is way too slow to do all the time

633 --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

634 subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())

635 subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())

636+ return $ if null subsubs'

637+ then Nothing

635− return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))

638+ else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))

636 liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'

639 liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'

637− SubscriberHold h -> do

640+ SubscriberHold h -> {-# SCC "pg->SubscriberHold" #-} do

638 invalidators <- liftIO $ readIORef $ holdInvalidators h

641 invalidators <- liftIO $ readIORef $ holdInvalidators h

639 when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

642 when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

640 toAssignRef <- askToAssignRef

643 toAssignRef <- askToAssignRef

641 liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)

644 liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)

642− SubscriberSwitch subscribed -> do

645+ SubscriberSwitch subscribed -> {-# SCC "pg->SubscriberSwitch" #-} do

643 when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed

646 when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed

644 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

647 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

645 scheduleClear $ switchSubscribedOccurrence subscribed

648 scheduleClear $ switchSubscribedOccurrence subscribed

646 subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed

649 subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed

647 liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs

650 liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs

648− SubscriberCoincidenceOuter subscribed -> do

651+ SubscriberCoincidenceOuter subscribed -> {-# SCC "pg->SubscriberCoincidenceOuter" #-} do

649 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

652 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

650 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

653 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

651 when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight

654 when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight

@@ -664,7 +667,7 @@ propagate a subscribers = do

664 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

667 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

665 scheduleClear $ coincidenceSubscribedOccurrence subscribed

668 scheduleClear $ coincidenceSubscribedOccurrence subscribed

666 liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))

669 liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))

667− SubscriberCoincidenceInner subscribed -> do

670+ SubscriberCoincidenceInner subscribed -> {-# SCC "pg->SubscriberCoincidenceInner" #-} do

668 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed

671 when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed

669 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

672 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

670 scheduleClear $ coincidenceSubscribedOccurrence subscribed

673 scheduleClear $ coincidenceSubscribedOccurrence subscribed

@@ -731,7 +734,7 @@ readBehaviorTracked b = case b of

731

734

732readEvent :: Event a -> ResultM (Maybe a)

735readEvent :: Event a -> ResultM (Maybe a)

733readEvent e = case e of

736readEvent 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

735 EventNever -> return Nothing

738 EventNever -> return Nothing

736 EventPush p -> do

739 EventPush p -> do

737 subscribed <- getPushSubscribed p

740 subscribed <- getPushSubscribed p

@@ -747,7 +750,7 @@ readEvent e = case e of

747 return result

750 return result

748 EventFan k f -> do

751 EventFan k f -> do

749 parentOcc <- readEvent $ fanParent f

752 parentOcc <- readEvent $ fanParent f

750− return $ DMap.lookup k =<< parentOcc

753+ return . coerce $ DMap.lookup k =<< parentOcc

751 EventSwitch s -> do

754 EventSwitch s -> do

752 subscribed <- getSwitchSubscribed s

755 subscribed <- getSwitchSubscribed s

753 liftIO $ do

756 liftIO $ do

@@ -794,7 +797,7 @@ subscribeEventSubscribed es ws = case es of

794 modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)

797 modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)

795 EventSubscribedFan k subscribed -> do

798 EventSubscribedFan k subscribed -> do

796 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"

799 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])

798 EventSubscribedMerge subscribed -> do

801 EventSubscribedMerge subscribed -> do

799 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"

802 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"

800 modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)

803 modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)

@@ -812,7 +815,7 @@ getEventSubscribedOcc es = case es of

812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

815 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

813 EventSubscribedFan k subscribed -> do

816 EventSubscribedFan k subscribed -> do

814 parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed

817 parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed

815− let occ = DMap.lookup k =<< parentOcc

818+ let occ = coerce $ DMap.lookup k =<< parentOcc

816 return occ

819 return occ

817 EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed

820 EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed

818 EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed

821 EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed

@@ -841,18 +844,18 @@ noinlineFalse = False

841getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

844getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

842getRootSubscribed k r = do

845getRootSubscribed k r = do

843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

846 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

844− case DMap.lookup (WrapArg k) mSubscribed of

847+ case DMap.lookup k mSubscribed of

845 Just subscribed -> return subscribed

848 Just subscribed -> return subscribed

846 Nothing -> liftIO $ do

849 Nothing -> liftIO $ do

847 subscribersRef <- newIORef []

850 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

849 -- 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

852 -- 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

850 uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)

853 uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)

851 addFinalizer subscribed $ do

854 addFinalizer subscribed $ do

852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

855 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

853-- putStrLn "Uninit root"

856-- putStrLn "Uninit root"

854 uninit

857 uninit

855− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed

858+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed

856 return subscribed

859 return subscribed

857

860

858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

861-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

@@ -894,11 +897,11 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do

894 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

897 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

895 s <- liftIO $ newBox subscribedUnsafe

898 s <- liftIO $ newBox subscribedUnsafe

896 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"

899 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

898 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws

901 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws

899 parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd

902 parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd

900 height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

903 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)

902 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers

905 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers

903 subscriberHeights = map (\(_, _, x, _) -> x) subscribers

906 subscriberHeights = map (\(_, _, x, _) -> x) subscribers

904 myHeight =

907 myHeight =

@@ -1048,7 +1051,7 @@ getCoincidenceSubscribed c = do

1048 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1051 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1049 return subscribed

1052 return subscribed

1050

1053

1051−merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)

1054+merge :: GCompare k => DMap k Event -> Event (DMap k Identity)

1052merge m = EventMerge $ Merge

1055merge m = EventMerge $ Merge

1053 { mergeParents = m

1056 { mergeParents = m

1054 , mergeSubscribed = unsafeNewIORef m Nothing

1057 , mergeSubscribed = unsafeNewIORef m Nothing

@@ -1056,7 +1059,7 @@ merge m = EventMerge $ Merge

1056

1059

1057newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }

1060newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }

1058

1061

1059−fan :: GCompare k => Event (DMap k) -> EventSelector k

1062+fan :: GCompare k => Event (DMap k Identity) -> EventSelector k

1060fan e =

1063fan e =

1061 let f = Fan

1064 let f = Fan

1062 { fanParent = e

1065 { fanParent = e

@@ -1154,7 +1157,7 @@ invalidateSubscriberHeight ws = do

1154 SubscriberFan subscribed -> do

1157 SubscriberFan subscribed -> do

1155 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1158 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1156 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1159 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 ())

1158 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1161 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1159 SubscriberHold _ -> return ()

1162 SubscriberHold _ -> return ()

1160 SubscriberSwitch subscribed -> do

1163 SubscriberSwitch subscribed -> do

@@ -1205,7 +1208,7 @@ recalculateSubscriberHeight ws = do

1205 SubscriberFan subscribed -> do

1208 SubscriberFan subscribed -> do

1206 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1209 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1207 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1210 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 ())

1209 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1212 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1210 SubscriberHold _ -> return ()

1213 SubscriberHold _ -> return ()

1211 SubscriberSwitch subscribed -> do

1214 SubscriberSwitch subscribed -> do

@@ -1237,7 +1240,7 @@ recalculateCoincidenceHeight subscribed = do

1237

1240

1238calculateMergeHeight :: MergeSubscribed k -> IO Int

1241calculateMergeHeight :: MergeSubscribed k -> IO Int

1239calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do

1242calculateMergeHeight 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

1241 readIORef $ eventSubscribedHeightRef es

1244 readIORef $ eventSubscribedHeightRef es

1242 return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'

1245 return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'

1243

1246

@@ -1316,7 +1319,7 @@ instance R.Reflex Spider where

1316 constant = SpiderBehavior . BehaviorConst

1319 constant = SpiderBehavior . BehaviorConst

1317 push f = SpiderEvent. push f . unSpiderEvent

1320 push f = SpiderEvent. push f . unSpiderEvent

1318 pull = SpiderBehavior . pull

1321 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)

1320 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

1323 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

1321 switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior

1324 switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior

1322 coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent

1325 coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent

@@ -1340,7 +1343,7 @@ instance R.MonadHold Spider EventM where

1340 {-# INLINE hold #-}

1343 {-# INLINE hold #-}

1341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1344 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1342

1345

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)

1344newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1347newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1345

1348

1346instance R.MonadSubscribeEvent Spider SpiderHostFrame where

1349instance 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 #-}

3+module Reflex.Bench.Focused where

5+import Reflex

6+import Reflex.TestPlan

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

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

10import Reflex.Class

11import Data.Functor.Misc

12−

12+import Control.Monad.Identity

13import Control.Monad

14import Data.MemoTrie

15import Data.Dependent.Map (DMap, GCompare)

@@ -40,15 +40,15 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

40 pull :: PullM (Pure t) a -> Behavior (Pure t) a

41 pull = Behavior . memo

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)

44 merge events = Event $ memo $ \t ->

45 let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events

46 in if DMap.null currentOccurrences

47 then Nothing

48 else Just currentOccurrences

50− fan :: GCompare k => Event (Pure t) (DMap k) -> EventSelector (Pure t) 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 >>= DMap.lookup k

51+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k

53 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

54 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

71 let times = relevantTestingTimes (bMap, eMap)

72 liftIO performGC

73 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

75 bOutput <- sample b'

76 eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do

77 mret <- readRef reTrigger

78 let firing = case mret of

79− Just ret -> [ret :=> val]

79+ Just ret -> [ret :=> Identity val]

80 Nothing -> []

81 fireEventsAndRead firing $ sequence =<< readEvent e'Handle

82 liftIO performGC

test/Reflex/TestPlan.hsnew file+45

@@ -0,0 +1,45 @@

2+module Reflex.TestPlan

3+ ( TestPlan(..)

5+ , TestCase (..)

6+ , testE, testB

7+ , TestE, TestB

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+