fe21a50 · reflex · git.iko.soy

git.iko.soy/reflex

Merge remote-tracking branch 'origin/fast-weak-partial-requester' into develop

commitfe21a501f7db4a3dbf5f7727c37bbe33fafee9ac authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 4 Oct 2017, 17:09 (9 years ago) parent25bd18d fab8302

29 files changed+1782−330

compare with develop

unifiedsplit

reflex.cabal+11−1 src/Data/AppendMap.hs+1−1 src/Data/FastMutableIntMap.hs+100 src/Data/FastWeakBag.hs+157 src/Data/Functor/Misc.hs+1 src/Reflex.hs+1 src/Reflex/Class.hs+167−46 src/Reflex/Dynamic.hs+4−4 src/Reflex/Dynamic/Uniq.hs+3−3 src/Reflex/DynamicWriter.hs+2−1 src/Reflex/EventWriter.hs+116−25 src/Reflex/FastWeak.hs+143 src/Reflex/Optimizer.hs+6−1 src/Reflex/Patch.hs+1−1 src/Reflex/Patch/Map.hs+4 src/Reflex/Patch/MapWithMove.hs+4−1 src/Reflex/PerformEvent/Base.hs+20−3 src/Reflex/PostBuild/Base.hs+55−11 src/Reflex/PostBuild/Class.hs+8 src/Reflex/Profiled.hs+205 src/Reflex/Pure.hs+15 src/Reflex/Query/Base.hs+2−1 src/Reflex/Requester/Base.hs+310−47 src/Reflex/Requester/Class.hs+20−34 src/Reflex/Spider/Internal.hs+386−149 src/Reflex/Spider/SpiderTimeline.include.hs+21−1 src/Reflex/TriggerEvent/Base.hs+6 src/Reflex/TriggerEvent/Class.hs+12 test/Reflex/Plan/Pure.hs+1

reflex.cabal+11−1

@@ -49,6 +49,7 @@ library

4949 MemoTrie == 0.6.*,

5050 base >= 4.7 && < 4.11,

5151 bifunctors >= 5.2 && < 5.5,

52+ comonad,

5253 containers == 0.5.*,

5354 data-default >= 0.5 && < 0.8,

5455 dependent-map >= 0.2.4 && < 0.3,

@@ -72,12 +73,15 @@ library

7273 Data.AppendMap,

7374 Data.Functor.Misc,

7475 Data.WeakBag,

76+ Data.FastWeakBag,

77+ Data.FastMutableIntMap,

7578 Reflex,

7679 Reflex.Class,

7780 Reflex.EventWriter,

7881 Reflex.Dynamic,

7982 Reflex.Dynamic.Uniq,

8083 Reflex.DynamicWriter,

84+ Reflex.FastWeak,

8185 Reflex.FunctorMaybe,

8286 Reflex.Host.Class,

8387 Reflex.Patch,

@@ -92,6 +96,7 @@ library

9296 Reflex.PerformEvent.Class,

9397 Reflex.PostBuild.Base,

9498 Reflex.PostBuild.Class,

99+ Reflex.Profiled,

95100 Reflex.Query.Base,

96101 Reflex.Query.Class,

97102 Reflex.Requester.Base,

@@ -100,7 +105,7 @@ library

100105 Reflex.Spider.Internal,

101106 Reflex.Widget.Basic

102107

103− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

108+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo

104109 ghc-prof-options: -fprof-auto

105110

106111 if flag(specialize-to-spidertimeline-global)

@@ -137,6 +142,9 @@ library

137142 if flag(experimental-dependent-sum-instances)

138143 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

139144

145+ if impl(ghcjs)

146+ build-depends: ghcjs-base

147+

140148test-suite semantics

141149 type: exitcode-stdio-1.0

142150 main-is: semantics.hs

@@ -183,6 +191,7 @@ test-suite hlint

183191 , hlint

184192 if impl(ghcjs)

185193 buildable: False

194+ buildable: False

186195

187196test-suite EventWriterT

188197 type: exitcode-stdio-1.0

@@ -208,6 +217,7 @@ test-suite RequesterT

208217 , transformers

209218 , reflex

210219 , ref-tf

220+ buildable: False

211221

212222test-suite QueryT

213223 type: exitcode-stdio-1.0

src/Data/AppendMap.hs+1−1

@@ -26,7 +26,7 @@ import Data.Semigroup

2626import Data.Set (Set)

2727import Data.Typeable

2828import GHC.Generics (Generic)

29−import Reflex (FunctorMaybe (..))

29+import Reflex.Class (FunctorMaybe (..))

3030import Reflex.Patch (Additive, Group (..))

3131

3232newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }

src/Data/FastMutableIntMap.hsnew file+100

@@ -0,0 +1,100 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveTraversable #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE TypeFamilies #-}

6+module Data.FastMutableIntMap

7+ ( FastMutableIntMap

8+ , new

9+ , newEmpty

10+ , insert

11+ , isEmpty

12+ , getFrozenAndClear

13+ , size

14+ , applyPatch

15+ , PatchIntMap (..)

16+ , traverseIntMapPatchWithKey

17+ , lookup

18+ , forIntersectionWithImmutable_

19+ , for_

20+ , patchIntMapNewElements

21+ , patchIntMapNewElementsMap

22+ , getDeletions

23+ ) where

24+

25+--TODO: Pure JS version

26+--TODO: Fast copy to FastIntMap

27+--TODO: Fast patch type

28+

29+import Prelude hiding (lookup)

30+import Data.IORef

31+import Data.IntMap.Strict (IntMap)

32+import qualified Data.IntMap.Strict as IntMap

33+import Data.Maybe

34+import Reflex.Patch.Class

35+import Data.Foldable (traverse_)

36+import Control.Monad.IO.Class

37+

38+newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))

39+

40+new :: IntMap a -> IO (FastMutableIntMap a)

41+new m = FastMutableIntMap <$> newIORef m

42+

43+newEmpty :: IO (FastMutableIntMap a)

44+newEmpty = FastMutableIntMap <$> newIORef IntMap.empty

45+

46+insert :: FastMutableIntMap a -> Int -> a -> IO ()

47+insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v

48+

49+lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)

50+lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r

51+

52+forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()

53+forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do

54+ a <- liftIO $ readIORef r

55+ traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b

56+

57+for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()

58+for_ (FastMutableIntMap r) f = do

59+ a <- liftIO $ readIORef r

60+ traverse_ f a

61+

62+isEmpty :: FastMutableIntMap a -> IO Bool

63+isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r

64+

65+size :: FastMutableIntMap a -> IO Int

66+size (FastMutableIntMap r) = IntMap.size <$> readIORef r

67+

68+-- | Make an immutable snapshot of the datastructure and clear it

69+getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)

70+getFrozenAndClear (FastMutableIntMap r) = do

71+ result <- readIORef r

72+ writeIORef r IntMap.empty

73+ return result

74+

75+applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)

76+applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do

77+ v <- readIORef r

78+ writeIORef r $! applyAlways p v

79+ return $ IntMap.intersection v m

80+

81+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

82+

83+instance Patch (PatchIntMap a) where

84+ type PatchTarget (PatchIntMap a) = IntMap a

85+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

86+ let removes = IntMap.filter isNothing p

87+ adds = IntMap.mapMaybe id p

88+ in IntMap.union adds $ v `IntMap.difference` removes

89+

90+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

91+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

92+

93+patchIntMapNewElements :: PatchIntMap a -> [a]

94+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

95+

96+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

97+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

98+

99+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

100+getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Data/FastWeakBag.hsnew file+157

@@ -0,0 +1,157 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+#ifdef USE_REFLEX_OPTIMIZER

4+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

5+#endif

6+#ifdef ghcjs_HOST_OS

7+{-# LANGUAGE ForeignFunctionInterface #-}

8+{-# LANGUAGE JavaScriptFFI #-}

9+#endif

10+-- | This module defines the 'FastWeakBag' type, which represents a mutable

11+-- collection of items that does not cause the items to be retained in memory.

12+-- This is useful for situations where a value needs to be inspected or modified

13+-- if it is still alive, but can be ignored if it is dead.

14+module Data.FastWeakBag

15+ ( FastWeakBag

16+ , FastWeakBagTicket

17+ , empty

18+ , isEmpty

19+ , insert

20+ , traverse

21+ , remove

22+ -- * Internal functions

23+ -- These will not always be available.

24+#ifndef ghcjs_HOST_OS

25+ , _weakBag_children --TODO: Don't export this

26+#endif

27+ ) where

28+

29+import Control.Monad hiding (forM_, mapM_)

30+import Control.Monad.IO.Class

31+

32+#ifdef ghcjs_HOST_OS

33+import GHCJS.Types

34+import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)

35+#else

36+import Control.Exception

37+import Data.Foldable (forM_, mapM_)

38+import Data.IntMap.Strict (IntMap)

39+import qualified Data.IntMap.Strict as IntMap

40+import Data.IORef

41+import System.Mem.Weak

42+#endif

43+

44+import Prelude hiding (mapM_, traverse)

45+

46+-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -

47+-- that is, they can still be garbage-collected. As long as the @a@s remain

48+-- alive, the 'FastWeakBag' will continue to refer to them.

49+#ifdef ghcjs_HOST_OS

50+newtype FastWeakBag a = FastWeakBag JSVal

51+#else

52+data FastWeakBag a = FastWeakBag

53+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

54+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))

55+ }

56+#endif

57+

58+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If

59+-- the caller retains the ticket, the item is guranteed to stay in memory (and

60+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from

61+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.

62+#ifdef ghcjs_HOST_OS

63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal

64+#else

65+data FastWeakBagTicket a = FastWeakBagTicket

66+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)

67+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a

68+ }

69+#endif

70+

71+-- | Insert an item into a 'FastWeakBag'.

72+{-# INLINE insert #-}

73+insert :: a -- ^ The item

74+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into

75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item

76+ -- is retained and allows the item to be removed.

77+#ifdef ghcjs_HOST_OS

78+insert a wb = js_insert (unsafeToRawJSVal a) wb

79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)

80+#else

81+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do

82+ a' <- evaluate a

83+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)

84+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())

85+ wa <- mkWeakPtr a' $ Just cleanup

86+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

87+ return $ FastWeakBagTicket

88+ { _weakBagTicket_weakItem = wa

89+ , _weakBagTicket_item = a'

90+ }

91+#endif

92+

93+-- | Create an empty 'FastWeakBag'.

94+{-# INLINE empty #-}

95+empty :: IO (FastWeakBag a)

96+#ifdef ghcjs_HOST_OS

97+empty = js_empty

98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)

99+#else

100+empty = {-# SCC "empty" #-} do

101+ nextId <- newIORef 1

102+ children <- newIORef IntMap.empty

103+ let bag = FastWeakBag

104+ { _weakBag_nextId = nextId

105+ , _weakBag_children = children

106+ }

107+ return bag

108+#endif

109+

110+-- | Check whether a 'FastWeakBag' is empty.

111+{-# INLINE isEmpty #-}

112+isEmpty :: FastWeakBag a -> IO Bool

113+#ifdef ghcjs_HOST_OS

114+isEmpty = js_isEmpty

115+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time

116+#else

117+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)

118+#endif

119+

120+{-# INLINE traverse #-}

121+-- | Visit every node in the given list. If new nodes are appended during the

122+-- traversal, they will not be visited. Every live node that was in the list

123+-- when the traversal began will be visited exactly once; however, no guarantee

124+-- is made about the order of the traversal.

125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

126+#ifdef ghcjs_HOST_OS

127+traverse wb f = do

128+ let go cursor = when (not $ js_isNull cursor) $ do

129+ val <- liftIO $ js_getTicketValue cursor

130+ f $ unsafeFromRawJSVal val

131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))

132+ go =<< liftIO (js_getInitial wb)

133+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal

135+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag

136+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

137+#else

138+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do

139+ cs <- liftIO $ readIORef children

140+ forM_ cs $ \c -> do

141+ ma <- liftIO $ deRefWeak c

142+ mapM_ f ma

143+#endif

144+

145+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times

146+-- on the same 'FastWeakBagTicket'.

147+{-# INLINE remove #-}

148+remove :: FastWeakBagTicket a -> IO ()

149+#ifdef ghcjs_HOST_OS

150+remove = js_remove

151+foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here

152+#else

153+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w

154+#endif

155+--TODO: Should 'remove' also drop the reference to the item?

156+

157+--TODO: can/should we provide a null FastWeakBagTicket?

src/Data/Functor/Misc.hs+1

@@ -7,6 +7,7 @@

77{-# LANGUAGE KindSignatures #-}

88{-# LANGUAGE LambdaCase #-}

99{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PatternSynonyms #-}

1011{-# LANGUAGE PolyKinds #-}

1112{-# LANGUAGE RankNTypes #-}

1213{-# LANGUAGE ScopedTypeVariables #-}

src/Reflex.hs+1

@@ -17,6 +17,7 @@ import Reflex.PerformEvent.Base as X

1717import Reflex.PerformEvent.Class as X

1818import Reflex.PostBuild.Base as X

1919import Reflex.PostBuild.Class as X

20+import Reflex.Profiled as X

2021import Reflex.Query.Base as X

2122import Reflex.Query.Class as X

2223import Reflex.Requester.Base as X

src/Reflex/Class.hs+167−46

@@ -29,6 +29,7 @@ module Reflex.Class

2929 ( module Reflex.Patch

3030 -- * Primitives

3131 , Reflex (..)

32+ , mergeInt

3233 , coerceBehavior

3334 , coerceEvent

3435 , coerceDynamic

@@ -36,6 +37,7 @@ module Reflex.Class

3637 , MonadHold (..)

3738 -- ** 'fan'-related types

3839 , EventSelector (..)

40+ , EventSelectorInt (..)

3941 -- ** 'Incremental'-related types

4042 -- * Convenience functions

4143 , constDyn

@@ -76,6 +78,22 @@ module Reflex.Class

7678 , zipDynWith

7779 -- ** Accumulating state

7880 , Accumulator (..)

81+ , accumDyn

82+ , accumMDyn

83+ , accumMaybeDyn

84+ , accumMaybeMDyn

85+ , mapAccumDyn

86+ , mapAccumMDyn

87+ , mapAccumMaybeDyn

88+ , mapAccumMaybeMDyn

89+ , accumB

90+ , accumMB

91+ , accumMaybeB

92+ , accumMaybeMB

93+ , mapAccumB

94+ , mapAccumMB

95+ , mapAccumMaybeB

96+ , mapAccumMaybeMB

7997 , mapAccum_

8098 , mapAccumM_

8199 , mapAccumMaybe_

@@ -83,9 +101,9 @@ module Reflex.Class

83101 , zipListWithEvent

84102 , numberOccurrences

85103 , numberOccurrencesFrom

104+ , numberOccurrencesFrom_

86105 , (<@>)

87106 , (<@)

88− , headE

89107 , tailE

90108 , headTailE

91109 , takeWhileE

@@ -120,6 +138,8 @@ module Reflex.Class

120138 , tagCheap

121139 , mergeWithCheap

122140 , mergeWithCheap'

141+ -- * Slow, but general, implementations

142+ , slowHeadE

123143#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

124144 , Spider

125145 , SpiderEnv

@@ -174,6 +194,8 @@ import qualified Data.Functor.Bind as Bind

174194import Data.Functor.Constant

175195import Data.Functor.Misc

176196import Data.Functor.Plus

197+import Data.IntMap.Strict (IntMap)

198+import qualified Data.IntMap.Strict as IntMap

177199import Data.List.NonEmpty (NonEmpty (..))

178200import Data.Map (Map)

179201import Data.Maybe

@@ -185,6 +207,7 @@ import Data.Traversable

185207import Data.Type.Coercion

186208import Reflex.FunctorMaybe

187209import Reflex.Patch

210+import Data.FastMutableIntMap (PatchIntMap)

188211

189212#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

190213import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

@@ -300,8 +323,14 @@ class ( MonadHold t (PushM t)

300323 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

301324 -- occurrence type

302325 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

326+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

327+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a

303328#endif

304329

330+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

331+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

332+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

333+

305334#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

306335instance t ~ SpiderTimeline Global => Reflex t where

307336 newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

@@ -431,8 +460,20 @@ class MonadSample t m => MonadHold t m where

431460 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

432461 holdIncremental v0 = lift . holdIncremental v0

433462 buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)

463+ {-

434464 default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)

435465 buildDynamic getV0 = lift . buildDynamic getV0

466+ -}

467+ -- | Create a new 'Event' that only occurs only once, on the first occurence of

468+ -- the supplied 'Event'.

469+ headE :: Event t a -> m (Event t a)

470+

471+

472+slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

473+slowHeadE e = do

474+ rec be <- hold e $ fmapCheap (const never) e'

475+ let e' = switch be

476+ return e'

436477

437478-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

438479-- key. This is much more efficient than filtering for each key with

@@ -448,6 +489,8 @@ newtype EventSelector t k = EventSelector

448489 select :: forall a. k a -> Event t a

449490 }

450491

492+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }

493+

451494--------------------------------------------------------------------------------

452495-- Instances

453496--------------------------------------------------------------------------------

@@ -460,6 +503,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

460503 holdDyn a0 = lift . holdDyn a0

461504 holdIncremental a0 = lift . holdIncremental a0

462505 buildDynamic a0 = lift . buildDynamic a0

506+ headE = lift . headE

463507

464508instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

465509 sample = lift . sample

@@ -469,6 +513,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

469513 holdDyn a0 = lift . holdDyn a0

470514 holdIncremental a0 = lift . holdIncremental a0

471515 buildDynamic a0 = lift . buildDynamic a0

516+ headE = lift . headE

472517

473518instance MonadSample t m => MonadSample t (StateT s m) where

474519 sample = lift . sample

@@ -478,6 +523,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where

478523 holdDyn a0 = lift . holdDyn a0

479524 holdIncremental a0 = lift . holdIncremental a0

480525 buildDynamic a0 = lift . buildDynamic a0

526+ headE = lift . headE

481527

482528instance MonadSample t m => MonadSample t (ExceptT e m) where

483529 sample = lift . sample

@@ -486,6 +532,8 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

486532 hold a0 = lift . hold a0

487533 holdDyn a0 = lift . holdDyn a0

488534 holdIncremental a0 = lift . holdIncremental a0

535+ buildDynamic a0 = lift . buildDynamic a0

536+ headE = lift . headE

489537

490538instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where

491539 sample = lift . sample

@@ -494,6 +542,8 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

494542 hold a0 = lift . hold a0

495543 holdDyn a0 = lift . holdDyn a0

496544 holdIncremental a0 = lift . holdIncremental a0

545+ buildDynamic a0 = lift . buildDynamic a0

546+ headE = lift . headE

497547

498548instance MonadSample t m => MonadSample t (ContT r m) where

499549 sample = lift . sample

@@ -502,6 +552,8 @@ instance MonadHold t m => MonadHold t (ContT r m) where

502552 hold a0 = lift . hold a0

503553 holdDyn a0 = lift . holdDyn a0

504554 holdIncremental a0 = lift . holdIncremental a0

555+ buildDynamic a0 = lift . buildDynamic a0

556+ headE = lift . headE

505557

506558--------------------------------------------------------------------------------

507559-- Convenience functions

@@ -602,6 +654,8 @@ instance Reflex t => Bind (Event t) where

602654instance Reflex t => Functor (Event t) where

603655 {-# INLINE fmap #-}

604656 fmap f = fmapMaybe $ Just . f

657+ {-# INLINE (<$) #-}

658+ x <$ e = fmapCheap (const x) e

605659

606660instance Reflex t => FunctorMaybe (Event t) where

607661 {-# INLINE fmapMaybe #-}

@@ -632,14 +686,6 @@ attachWith f = attachWithMaybe $ \a b -> Just $ f a b

632686attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

633687attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b

634688

635−-- | Create a new 'Event' that only occurs only once, on the first occurence of

636−-- the supplied 'Event'.

637−headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

638−headE e = do

639− rec be <- hold e $ fmap (const never) e'

640− let e' = switch be

641− return e'

642−

643689-- | Create a new 'Event' that occurs on all but the first occurence of the

644690-- supplied 'Event'.

645691tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

@@ -711,10 +757,9 @@ mergeWith = mergeWith' id

711757

712758{-# INLINE mergeWith' #-}

713759mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

714−mergeWith' f g es = fmap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

715− . merge

716− . DMap.fromDistinctAscList

717− . map (\(k, v) -> Const2 k :=> v)

760+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)

761+ . mergeInt

762+ . IntMap.fromDistinctAscList

718763 $ zip [0 :: Int ..] es

719764

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

@@ -880,6 +925,12 @@ alignEventWithMaybe f ea eb =

880925

881926-- | An 'Accumulator' type can be built by accumulating occurrences of an

882927-- 'Event'.

928+#if __GLASGOW_HASKELL__ < 802

929+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

930+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

931+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

932+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

933+#endif

883934class Reflex t => Accumulator t f | f -> t where

884935 accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)

885936 accum f = accumMaybe $ \v o -> Just $ f v o

@@ -896,55 +947,115 @@ class Reflex t => Accumulator t f | f -> t where

896947 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

897948 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

898949

950+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)

951+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o

952+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)

953+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o

954+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)

955+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o

956+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)

957+accumMaybeMDyn f z e = do

958+ rec let e' = flip push e $ \o -> do

959+ v <- sample $ current d'

960+ f v o

961+ d' <- holdDyn z e'

962+ return d'

963+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

964+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o

965+mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

966+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o

967+mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

968+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o

969+mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

970+mapAccumMaybeMDyn f z e = do

971+ rec let e' = flip push e $ \o -> do

972+ v <- sample $ current d'

973+ result <- f v o

974+ return $ case result of

975+ (Nothing, Nothing) -> Nothing

976+ _ -> Just result

977+ d' <- holdDyn z $ fmapMaybe fst e'

978+ return (d', fmapMaybe snd e')

979+

980+{-# INLINE accumB #-}

981+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)

982+accumB f = accumMaybeB $ \v o -> Just $ f v o

983+{-# INLINE accumMB #-}

984+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)

985+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o

986+{-# INLINE accumMaybeB #-}

987+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)

988+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

989+{-# INLINE accumMaybeMB #-}

990+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

991+accumMaybeMB f z e = do

992+ rec let e' = flip push e $ \o -> do

993+ v <- sample d'

994+ f v o

995+ d' <- hold z e'

996+ return d'

997+{-# INLINE mapAccumB #-}

998+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)

999+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o

1000+{-# INLINE mapAccumMB #-}

1001+mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1002+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o

1003+{-# INLINE mapAccumMaybeB #-}

1004+mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1005+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o

1006+

1007+{-# INLINE mapAccumMaybeMB #-}

1008+mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1009+mapAccumMaybeMB f z e = do

1010+ rec let e' = flip push e $ \o -> do

1011+ v <- sample d'

1012+ result <- f v o

1013+ return $ case result of

1014+ (Nothing, Nothing) -> Nothing

1015+ _ -> Just result

1016+ d' <- hold z $ fmapMaybe fst e'

1017+ return (d', fmapMaybe snd e')

1018+

8991019-- | Accumulate occurrences of an 'Event', producing an output occurrence each

9001020-- time. Discard the underlying 'Accumulator'.

1021+{-# INLINE mapAccum_ #-}

9011022mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)

9021023mapAccum_ f z e = do

903− (_ :: Behavior t a, result) <- mapAccum f z e

1024+ (_, result) <- mapAccumB f z e

9041025 return result

9051026

9061027-- | Accumulate occurrences of an 'Event', possibly producing an output

9071028-- occurrence each time. Discard the underlying 'Accumulator'.

1029+{-# INLINE mapAccumMaybe_ #-}

9081030mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

9091031mapAccumMaybe_ f z e = do

910− (_ :: Behavior t a, result) <- mapAccumMaybe f z e

1032+ (_, result) <- mapAccumMaybeB f z e

9111033 return result

9121034

9131035-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

9141036-- an output occurrence each time. Discard the underlying 'Accumulator'.

1037+{-# INLINE mapAccumM_ #-}

9151038mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)

9161039mapAccumM_ f z e = do

917− (_ :: Behavior t a, result) <- mapAccumM f z e

1040+ (_, result) <- mapAccumMB f z e

9181041 return result

9191042

9201043-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

9211044-- producing an output occurrence each time. Discard the underlying

9221045-- 'Accumulator'.

1046+{-# INLINE mapAccumMaybeM_ #-}

9231047mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

9241048mapAccumMaybeM_ f z e = do

925− (_ :: Behavior t a, result) <- mapAccumMaybeM f z e

1049+ (_, result) <- mapAccumMaybeMB f z e

9261050 return result

9271051

9281052instance Reflex t => Accumulator t (Dynamic t) where

929− accumMaybeM f z e = do

930− rec let e' = flip push e $ \o -> do

931− v <- sample $ current d'

932− f v o

933− d' <- holdDyn z e'

934− return d'

935− mapAccumMaybeM f z e = do

936− rec let e' = flip push e $ \o -> do

937− v <- sample $ current d'

938− result <- f v o

939− return $ case result of

940− (Nothing, Nothing) -> Nothing

941− _ -> Just result

942− d' <- holdDyn z $ fmapMaybe fst e'

943− return (d', fmapMaybe snd e')

1053+ accumMaybeM = accumMaybeMDyn

1054+ mapAccumMaybeM = mapAccumMaybeMDyn

9441055

9451056instance Reflex t => Accumulator t (Behavior t) where

946− accumMaybeM f z e = current <$> accumMaybeM f z e

947− mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e

1057+ accumMaybeM = accumMaybeMB

1058+ mapAccumMaybeM = mapAccumMaybeMB

9481059

9491060instance Reflex t => Accumulator t (Event t) where

9501061 accumMaybeM f z e = updated <$> accumMaybeM f z e

@@ -961,19 +1072,26 @@ zipListWithEvent f l e = do

9611072 mapAccumMaybe_ f' l e

9621073

9631074-- | Assign a number to each occurence of the given 'Event', starting from 0

1075+{-# INLINE numberOccurrences #-}

9641076numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

9651077numberOccurrences = numberOccurrencesFrom 0

9661078

9671079-- | Assign a number to each occurence of the given 'Event'

1080+{-# INLINE numberOccurrencesFrom #-}

9681081numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

9691082numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))

9701083

1084+-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values

1085+{-# INLINE numberOccurrencesFrom_ #-}

1086+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)

1087+numberOccurrencesFrom_ = mapAccum_ (\n _ -> (n + 1, n))

1088+

9711089-- | This is used to sample the value of a 'Behavior' using an 'Event'.

9721090--

973−-- The '<@>' operator is intended to be used in conjunction with

1091+-- The '<@>' operator is intended to be used in conjunction with

9741092-- the 'Applicative' instance for 'Behavior'.

9751093--

976−-- This is useful when we want to combine the values of one 'Event' and

1094+-- This is useful when we want to combine the values of one 'Event' and

9771095-- the value of several 'Behavior's at the time the 'Event' is firing.

9781096--

9791097-- If we have:

@@ -993,7 +1111,7 @@ numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))

9931111--

9941112-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d

9951113--

996−-- or a variation involing a custom data type to hold the combination of

1114+-- or a variation involing a custom data type to hold the combination of

9971115-- 'Behavior's even when that combination might only ever be used by 'f'.

9981116--

9991117-- A more suggestive example might be:

@@ -1010,8 +1128,8 @@ infixl 4 <@>

10101128--

10111129-- Alternatively, it is 'tag' in operator form.

10121130--

1013−-- This is useful when we want to combine the values of several

1014−-- 'Behavior's at particular points in time using an 'Applicative'

1131+-- This is useful when we want to combine the values of several

1132+-- 'Behavior's at particular points in time using an 'Applicative'

10151133-- style syntax.

10161134--

10171135-- If we have:

@@ -1022,16 +1140,16 @@ infixl 4 <@>

10221140-- > e :: Event t c

10231141--

10241142-- where 'e' is firing at the points in time of interest.

1025−--

1143+--

10261144-- Then we can use '<@':

10271145--

10281146-- > g <$> b1 <*> b2 <@ e :: Event t d

10291147--

1030−-- to combine the values of 'b1' and 'b2' at each of those points of time,

1148+-- to combine the values of 'b1' and 'b2' at each of those points of time,

10311149-- with the function 'g' being used to combine the values.

10321150--

10331151-- This is the same as '<@>' except that the 'Event' is being used only

1034−-- to act as a trigger.

1152+-- to act as a trigger.

10351153(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b

10361154(<@) = tag

10371155infixl 4 <@

@@ -1044,6 +1162,7 @@ infixl 4 <@

10441162-- to determine what the best meaning for this class is in such cases.

10451163class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

10461164 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1165+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))

10471166 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

10481167 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

10491168

@@ -1051,6 +1170,9 @@ instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where

10511170 runWithReplace a0 a' = do

10521171 r <- ask

10531172 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1173+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do

1174+ r <- ask

1175+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

10541176 traverseDMapWithKeyWithAdjust f dm0 dm' = do

10551177 r <- ask

10561178 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

@@ -1108,10 +1230,9 @@ mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

11081230{-# INLINE mergeWithFoldCheap' #-}

11091231mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

11101232mergeWithFoldCheap' f es =

1111− fmapCheap (f . (\(h : t) -> h :| t) . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

1112− . merge

1113− . DMap.fromDistinctAscList

1114− . map (\(k, v) -> Const2 k :=> v)

1233+ fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)

1234+ . mergeInt

1235+ . IntMap.fromDistinctAscList

11151236 $ zip [0 :: Int ..] es

11161237

11171238--------------------------------------------------------------------------------

src/Reflex/Dynamic.hs+4−4

@@ -143,12 +143,12 @@ scanDynMaybe z f d = do

143143-- 'Event' occurs using a folding function on the previous value and the value

144144-- of the 'Event'.

145145foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

146−foldDyn = accum . flip

146+foldDyn = accumDyn . flip

147147

148148-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it

149149-- can 'sample' existing 'Behaviors' and 'hold' new ones.

150150foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)

151−foldDynM = accumM . flip

151+foldDynM = accumMDyn . flip

152152

153153-- | Create a 'Dynamic' using the provided initial value and change it each time

154154-- the provided 'Event' occurs, using a function to combine the old value with

@@ -157,12 +157,12 @@ foldDynM = accumM . flip

157157-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire

158158-- in the 'Nothing' case.

159159foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)

160−foldDynMaybe = accumMaybe . flip

160+foldDynMaybe = accumMaybeDyn . flip

161161

162162-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it

163163-- can 'sample' existing 'Behaviors' and 'hold' new ones.

164164foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

165−foldDynMaybeM = accumMaybeM . flip

165+foldDynMaybeM = accumMaybeMDyn . flip

166166

167167-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.

168168count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

src/Reflex/Dynamic/Uniq.hs+3−3

@@ -31,7 +31,7 @@ newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a }

3131

3232-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.

3333uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a

34−uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip push (updated d) $ \new -> do --TODO: It would be very nice if we had an uncached push here

34+uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do

3535 old <- sample $ current d --TODO: Is it better to sample ourselves here?

3636 return $ unsafeJustChanged old new

3737

@@ -81,13 +81,13 @@ instance Reflex t => Accumulator t (UniqDynamic t) where

8181 let f' old change = do

8282 mNew <- f old change

8383 return $ unsafeJustChanged old =<< mNew

84− d <- accumMaybeM f' z e

84+ d <- accumMaybeMDyn f' z e

8585 return $ UniqDynamic d

8686 mapAccumMaybeM f z e = do

8787 let f' old change = do

8888 (mNew, output) <- f old change

8989 return (unsafeJustChanged old =<< mNew, output)

90− (d, out) <- mapAccumMaybeM f' z e

90+ (d, out) <- mapAccumMaybeMDyn f' z e

9191 return (UniqDynamic d, out)

9292

9393instance Reflex t => Functor (UniqDynamic t) where

src/Reflex/DynamicWriter.hs+2−1

@@ -188,4 +188,5 @@ withDynamicWriterT f dw = do

188188instance Requester t m => Requester t (DynamicWriterT t w m) where

189189 type Request (DynamicWriterT t w m) = Request m

190190 type Response (DynamicWriterT t w m) = Response m

191− withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

191+ requesting = lift . requesting

192+ requesting_ = lift . requesting_

src/Reflex/EventWriter.hs+116−25

@@ -9,6 +9,7 @@

99{-# LANGUAGE Rank2Types #-}

1010{-# LANGUAGE ScopedTypeVariables #-}

1111{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

1213{-# LANGUAGE UndecidableInstances #-}

1314#ifdef USE_REFLEX_OPTIMIZER

1415{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

@@ -34,35 +35,88 @@ import Control.Monad.Identity

3435import Control.Monad.Reader

3536import Control.Monad.Ref

3637import Control.Monad.State.Strict

37−import Data.Dependent.Map (DMap)

38+import Data.Dependent.Map (DMap, DSum (..))

3839import qualified Data.Dependent.Map as DMap

40+import Data.FastMutableIntMap

3941import Data.Foldable

4042import Data.Functor.Compose

4143import Data.Functor.Misc

44+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))

45+import Data.IntMap.Strict (IntMap)

46+import qualified Data.IntMap.Strict as IntMap

4247import Data.List.NonEmpty (NonEmpty (..))

4348import Data.Map (Map)

4449import Data.Semigroup

45−import Data.Sequence

4650import Data.Some (Some)

4751import Data.Tuple

52+import Data.Type.Equality

53+

54+import Unsafe.Coerce

4855

4956-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'

5057-- and combines them monoidally to provide an 'Event' result.

5158class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where

5259 tellEvent :: Event t w -> m ()

5360

61+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

62+newtype TellId w x

63+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead

64+ deriving (Show, Eq, Ord, Enum)

65+

66+tellId :: Int -> TellId w w

67+tellId = TellId

68+{-# INLINE tellId #-}

69+

70+tellIdRefl :: TellId w x -> w :~: x

71+tellIdRefl _ = unsafeCoerce Refl

72+

73+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

74+withTellIdRefl tid r = case tellIdRefl tid of

75+ Refl -> r

76+

77+instance GEq (TellId w) where

78+ a `geq` b =

79+ withTellIdRefl a $

80+ withTellIdRefl b $

81+ if a == b

82+ then Just Refl

83+ else Nothing

84+

85+instance GCompare (TellId w) where

86+ a `gcompare` b =

87+ withTellIdRefl a $

88+ withTellIdRefl b $

89+ case a `compare` b of

90+ LT -> GLT

91+ EQ -> GEQ

92+ GT -> GGT

93+

94+data EventWriterState t w = EventWriterState

95+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

96+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

97+ }

98+

5499-- | A basic implementation of 'EventWriter'.

55−newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }

100+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

56101 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

57102

58103-- | Run a 'EventWriterT' action.

59−runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

104+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

60105runEventWriterT (EventWriterT a) = do

61− (result, requests) <- runStateT a mempty

62− return (result, mconcat $ toList requests)

106+ (result, requests) <- runStateT a $ EventWriterState (-1) []

107+ let combineResults :: DMap (TellId w) Identity -> w

108+ combineResults = sconcat

109+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

110+ . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

111+ return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

63112

64113instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

65− tellEvent w = EventWriterT $ modify (|> w)

114+ tellEvent w = EventWriterT $ modify $ \old ->

115+ let myId = _eventWriterState_nextId old

116+ in EventWriterState

117+ { _eventWriterState_nextId = pred myId

118+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

119+ }

66120

67121instance EventWriter t w m => EventWriter t w (ReaderT r m) where

68122 tellEvent = lift . tellEvent

@@ -74,20 +128,28 @@ instance MonadSample t m => MonadSample t (EventWriterT t w m) where

74128 sample = lift . sample

75129

76130instance MonadHold t m => MonadHold t (EventWriterT t w m) where

131+ {-# INLINABLE hold #-}

77132 hold v0 = lift . hold v0

133+ {-# INLINABLE holdDyn #-}

78134 holdDyn v0 = lift . holdDyn v0

135+ {-# INLINABLE holdIncremental #-}

79136 holdIncremental v0 = lift . holdIncremental v0

137+ {-# INLINABLE buildDynamic #-}

138+ buildDynamic a0 = lift . buildDynamic a0

139+ {-# INLINABLE headE #-}

140+ headE = lift . headE

80141

81142instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

82143 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

144+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental

83145 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

84146 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

85147

86148instance Requester t m => Requester t (EventWriterT t w m) where

87149 type Request (EventWriterT t w m) = Request m

88150 type Response (EventWriterT t w m) = Response m

89− withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f

90−

151+ requesting = lift . requesting

152+ requesting_ = lift . requesting_

91153

92154-- | Given a function like 'runWithReplace' for the underlying monad, implement

93155-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

@@ -99,24 +161,53 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Se

99161 -> Event t (EventWriterT t w m b)

100162 -> EventWriterT t w m (a, Event t b)

101163runWithReplaceEventWriterTWith f a0 a' = do

102− let g :: EventWriterT t w m c -> m (c, Seq (Event t w))

103− g (EventWriterT r) = runStateT r mempty

104− (result0, result') <- f (g a0) $ fmap g a'

105− request <- holdDyn (fmapCheap sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . mergeList . toList . snd) result'

164+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'

165+ request <- holdDyn (snd result0) $ fmapCheap snd result'

106166 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

107− EventWriterT $ modify $ flip (|>) $ coincidence $ updated request

108− EventWriterT $ modify $ flip (|>) $ switch $ current request

167+ tellEvent $ coincidence $ updated request

168+ tellEvent $ switch $ current request

109169 return (fst result0, fmapCheap fst result')

110170

171+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

172+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))

173+ => ( (IntMap.Key -> v -> m (Event t w, v'))

174+ -> IntMap v

175+ -> Event t (p v)

176+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

177+ )

178+ -> (p (Event t w) -> [Event t w])

179+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))

180+ -> (IntMap.Key -> v -> EventWriterT t w m v')

181+ -> IntMap v

182+ -> Event t (p v)

183+ -> EventWriterT t w m (IntMap v', Event t (p v'))

184+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

185+ let f' :: IntMap.Key -> v -> m (Event t w, v')

186+ f' k v = swap <$> runEventWriterT (f k v)

187+ (children0, children') <- base f' dm0 dm'

188+ let result0 = fmap snd children0

189+ result' = fmapCheap (fmap snd) children'

190+ requests0 :: IntMap (Event t w)

191+ requests0 = fmap fst children0

192+ requests' :: Event t (p (Event t w))

193+ requests' = fmapCheap (fmap fst) children'

194+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'

195+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

196+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

197+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

198+ [] -> Nothing

199+ h : t -> Just $ sconcat $ h :| t

200+ return (result0, result')

201+

111202-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

112203sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

113− => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))

204+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

114205 -> DMap k v

115206 -> Event t (p k v)

116− -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))

207+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

117208 )

118− -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')

119− -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> Event t w) -> p k (Compose ((,) (Seq (Event t w))) v') -> p' (Some k) (Event t w))

209+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

210+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

120211 -> (p' (Some k) (Event t w) -> [Event t w])

121212 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))

122213 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

@@ -124,19 +215,19 @@ sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, M

124215 -> Event t (p k v)

125216 -> EventWriterT t w m (DMap k v', Event t (p k v'))

126217sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

127− let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)

128− f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty

218+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

219+ f' k v = Compose . swap <$> runEventWriterT (f k v)

129220 (children0, children') <- base f' dm0 dm'

130221 let result0 = DMap.map (snd . getCompose) children0

131222 result' = fforCheap children' $ mapPatch $ snd . getCompose

132223 requests0 :: Map (Some k) (Event t w)

133− requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0

224+ requests0 = weakenDMapWith (fst . getCompose) children0

134225 requests' :: Event t (p' (Some k) (Event t w))

135− requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose

226+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

136227 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'

137228 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

138− EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

139− EventWriterT $ modify $ flip (|>) $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

229+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

230+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

140231 [] -> Nothing

141232 h : t -> Just $ sconcat $ h :| t

142233 return (result0, result')

src/Reflex/FastWeak.hsnew file+143

@@ -0,0 +1,143 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+#ifdef ghcjs_HOST_OS

5+{-# LANGUAGE ForeignFunctionInterface #-}

6+{-# LANGUAGE JavaScriptFFI #-}

7+#endif

8+module Reflex.FastWeak

9+ ( FastWeakTicket

10+ , FastWeak

11+ , mkFastWeakTicket

12+ , getFastWeakTicketValue

13+ , getFastWeakTicketWeak

14+ , getFastWeakValue

15+ , getFastWeakTicket

16+ , emptyFastWeak

17+#ifdef ghcjs_HOST_OS

18+ --TODO: Move these elsewhere

19+ , unsafeFromRawJSVal

20+ , unsafeToRawJSVal

21+ , js_isNull

22+#endif

23+ ) where

24+

25+import GHC.Exts (Any)

26+import Unsafe.Coerce

27+

28+#ifdef ghcjs_HOST_OS

29+import GHCJS.Types

30+#else

31+import Control.Exception (evaluate)

32+import System.IO.Unsafe

33+import System.Mem.Weak

34+#endif

35+

36+

37+#ifdef ghcjs_HOST_OS

38+newtype FastWeakTicket a = FastWeakTicket JSVal

39+

40+newtype FastWeak a = FastWeak JSVal

41+

42+-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

43+data Val a = Val { unVal :: a }

44+

45+-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'

46+unsafeFromRawJSVal :: JSVal -> a

47+unsafeFromRawJSVal v = unVal (unsafeCoerce v)

48+

49+unsafeToRawJSVal :: a -> JSVal

50+unsafeToRawJSVal v = unsafeCoerce (Val v)

51+#else

52+data FastWeakTicket a = FastWeakTicket

53+ { _fastWeakTicket_val :: !a

54+ , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)

55+ }

56+

57+type FastWeak a = Weak a

58+#endif

59+

60+-- This needs to be in IO so we know that we've relinquished the ticket

61+getFastWeakTicketValue :: FastWeakTicket a -> IO a

62+#ifdef ghcjs_HOST_OS

63+getFastWeakTicketValue t = do

64+ v <- js_ticketVal t

65+ return $ unsafeFromRawJSVal v

66+

67+foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal

68+#else

69+getFastWeakTicketValue = return . _fastWeakTicket_val

70+#endif

71+

72+getFastWeakValue :: FastWeak a -> IO (Maybe a)

73+#ifdef ghcjs_HOST_OS

74+getFastWeakValue w = do

75+ r <- js_weakVal w

76+ case js_isNull r of

77+ True -> return Nothing

78+ False -> return $ Just $ unsafeFromRawJSVal r

79+

80+foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool

81+

82+foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal

83+#else

84+getFastWeakValue = deRefWeak

85+#endif

86+

87+getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

88+#ifdef ghcjs_HOST_OS

89+getFastWeakTicket w = do

90+ r <- js_weakTicket w

91+ case js_isNull r of

92+ True -> return Nothing

93+ False -> return $ Just $ FastWeakTicket r

94+

95+foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal

96+#else

97+getFastWeakTicket w = do

98+ deRefWeak w >>= \case

99+ Nothing -> return Nothing

100+ Just v -> return $ Just $ FastWeakTicket

101+ { _fastWeakTicket_val = v

102+ , _fastWeakTicket_weak = w

103+ }

104+#endif

105+

106+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak

107+mkFastWeakTicket :: a -> IO (FastWeakTicket a)

108+#ifdef ghcjs_HOST_OS

109+mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

110+

111+foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a)

112+#else

113+mkFastWeakTicket v = do

114+ v' <- evaluate v

115+ w <- mkWeakPtr v' Nothing

116+ return $ FastWeakTicket

117+ { _fastWeakTicket_val = v'

118+ , _fastWeakTicket_weak = w

119+ }

120+#endif

121+

122+-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

123+#ifdef ghcjs_HOST_OS

124+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

125+#else

126+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

127+getFastWeakTicketWeak = return . _fastWeakTicket_weak

128+#endif

129+

130+-- | A weak reference that is always empty

131+emptyFastWeak :: FastWeak a

132+emptyFastWeak = unsafeCoerce w

133+ where w :: FastWeak Any

134+#ifdef ghcjs_HOST_OS

135+ w = js_emptyWeak

136+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

137+#else

138+ w = unsafePerformIO $ do

139+ w' <- mkWeakPtr undefined Nothing

140+ finalize w'

141+ return w'

142+#endif

143+{-# NOINLINE emptyFastWeak #-}

src/Reflex/Optimizer.hs+6−1

@@ -31,7 +31,12 @@ plugin :: Plugin

3131plugin = defaultPlugin { installCoreToDos = install }

3232

3333install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

34−install [] p = return $ makeInlinable : p

34+install [] p = do

35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p

36+ let f = \case

37+ simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]

38+ x -> [x]

39+ return $ makeInlinable : concatMap f p

3540install options@(_:_) p = do

3641 warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"

3742 install [] p

src/Reflex/Patch.hs+1−1

@@ -10,7 +10,7 @@ import Reflex.Patch.Class as X

1010import Reflex.Patch.DMap as X

1111import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

1212import Reflex.Patch.Map as X

13−import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

1414

1515import Data.Semigroup (Semigroup (..), (<>))

1616

src/Reflex/Patch/Map.hs+4

@@ -16,6 +16,7 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

1616

1717instance Ord k => Patch (PatchMap k v) where

1818 type PatchTarget (PatchMap k v) = Map k v

19+ {-# INLINABLE apply #-}

1920 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

2021 where insertions = Map.mapMaybeWithKey (const id) p

2122 deletions = Map.mapMaybeWithKey (const nothingToJust) p

@@ -46,3 +47,6 @@ instance Functor (PatchMap k) where

4647patchMapNewElements :: PatchMap k v -> [v]

4748patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

4849

50+-- | Returns all the new elements that will be added to the 'Map'

51+patchMapNewElementsMap :: PatchMap k v -> Map k v

52+patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p

src/Reflex/Patch/MapWithMove.hs+4−1

@@ -62,7 +62,10 @@ instance Ord k => Patch (PatchMapWithMove k v) where

6262

6363-- | Returns all the new elements that will be added to the 'Map'

6464patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

65−patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ f <$> Map.elems p

65+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

66+

67+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

68+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

6669 where f ni = case _nodeInfo_from ni of

6770 From_Insert v -> Just v

6871 From_Move _ -> Nothing

src/Reflex/PerformEvent/Base.hs+20−3

@@ -40,6 +40,9 @@ import Data.Coerce

4040import Data.Dependent.Map (DMap)

4141import qualified Data.Dependent.Map as DMap

4242import Data.Dependent.Sum

43+import Data.FastMutableIntMap

44+import Data.IntMap.Strict (IntMap)

45+import qualified Data.IntMap.Strict as IntMap

4346

4447-- | A function that fires events for the given 'EventTrigger's and then runs

4548-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

@@ -76,8 +79,9 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT

7679 result0 <- lift a0

7780 result' <- requestingIdentity a'

7881 return (result0, result')

79− traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

80− traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

82+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

83+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

84+ traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

8185

8286defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

8387 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))

@@ -90,6 +94,17 @@ defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

9094 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

9195 return (result0, result')

9296

97+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

98+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))

99+ -> (IntMap.Key -> v -> HostFrame t v2)

100+ -> IntMap v

101+ -> Event t (p v)

102+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))

103+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do

104+ result0 <- lift $ IntMap.traverseWithKey f' dm0

105+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

106+ return (result0, result')

107+

93108instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

94109 {-# INLINABLE newEventWithTrigger #-}

95110 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

@@ -123,7 +138,7 @@ hostPerformEventT a = do

123138 case mToPerform of

124139 Nothing -> return [result']

125140 Just toPerform -> do

126− responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform

141+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform

127142 mrt <- readRef responseTrigger

128143 let followupEventTriggers = case mrt of

129144 Just rt -> [rt :=> Identity responses]

@@ -144,6 +159,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

144159 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

145160 {-# INLINABLE buildDynamic #-}

146161 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

162+ {-# INLINABLE headE #-}

163+ headE = PerformEventT . lift . headE

147164

148165instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

149166 type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/PostBuild/Base.hs+55−11

@@ -17,6 +17,9 @@

1717module Reflex.PostBuild.Base

1818 ( PostBuildT (..)

1919 , runPostBuildT

20+ -- * Internal

21+ , mapIntMapWithAdjustImpl

22+ , mapDMapWithAdjustImpl

2023 ) where

2124

2225import Reflex.Class

@@ -30,10 +33,12 @@ import Control.Monad.Identity

3033import Control.Monad.Primitive

3134import Control.Monad.Reader

3235import Control.Monad.Ref

33−import Control.Monad.Trans.Control

36+import qualified Control.Monad.Trans.Control as TransControl

3437import Data.Dependent.Map (DMap)

3538import qualified Data.Dependent.Map as DMap

3639import Data.Functor.Compose

40+import Data.IntMap.Strict (IntMap)

41+import qualified Data.IntMap.Strict as IntMap

3742

3843-- | Provides a basic implementation of 'PostBuild'.

3944newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

@@ -49,13 +54,6 @@ instance PrimMonad m => PrimMonad (PostBuildT x m) where

4954 type PrimState (PostBuildT x m) = PrimState m

5055 primitive = lift . primitive

5156

52−instance MonadTransControl (PostBuildT t) where

53− type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

54− {-# INLINABLE liftWith #-}

55− liftWith = defaultLiftWith PostBuildT unPostBuildT

56− {-# INLINABLE restoreT #-}

57− restoreT = defaultRestoreT PostBuildT

58−

5957instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

6058 {-# INLINABLE getPostBuild #-}

6159 getPostBuild = PostBuildT ask

@@ -71,13 +69,17 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

7169 holdDyn v0 = lift . holdDyn v0

7270 {-# INLINABLE holdIncremental #-}

7371 holdIncremental v0 = lift . holdIncremental v0

72+ {-# INLINABLE buildDynamic #-}

73+ buildDynamic a0 = lift . buildDynamic a0

74+ {-# INLINABLE headE #-}

75+ headE = lift . headE

7476

7577instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

76− type Performable (PostBuildT t m) = PostBuildT t (Performable m)

78+ type Performable (PostBuildT t m) = Performable m

7779 {-# INLINABLE performEvent_ #-}

78− performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

80+ performEvent_ = lift . performEvent_

7981 {-# INLINABLE performEvent #-}

80− performEvent e = liftWith $ \run -> performEvent $ fmap run e

82+ performEvent = lift . performEvent

8183

8284instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

8385 {-# INLINABLE newEventWithTrigger #-}

@@ -112,9 +114,39 @@ instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m

112114 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

113115 let voidResult' = fmapCheap (\_ -> ()) result'

114116 return result

117+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

118+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust

119+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

115120 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

116121 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

117122

123+{-# INLINABLE mapIntMapWithAdjustImpl #-}

124+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)

125+ => ( (IntMap.Key -> (Event t (), v) -> m v')

126+ -> IntMap (Event t (), v)

127+ -> Event t (p (Event t (), v))

128+ -> m (IntMap v', Event t (p v'))

129+ )

130+ -> (IntMap.Key -> v -> PostBuildT t m v')

131+ -> IntMap v

132+ -> Event t (p v)

133+ -> PostBuildT t m (IntMap v', Event t (p v'))

134+mapIntMapWithAdjustImpl base f dm0 dm' = do

135+ postBuild <- getPostBuild

136+ let loweredDm0 = fmap ((,) postBuild) dm0

137+ f' :: IntMap.Key -> (Event t (), v) -> m v'

138+ f' k (e, v) = do

139+ runPostBuildT (f k v) e

140+ lift $ do

141+ rec (result0, result') <- base f' loweredDm0 loweredDm'

142+ cohortDone <- numberOccurrencesFrom_ 1 result'

143+ numberedDm' <- numberOccurrencesFrom 1 dm'

144+ let postBuild' = fanInt $ fmapCheap (\n -> IntMap.singleton n ()) cohortDone

145+ loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do

146+ return $ fmap ((,) (selectInt postBuild' n)) p

147+ return (result0, result')

148+

149+{-# INLINABLE mapDMapWithAdjustImpl #-}

118150mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)

119151 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))

120152 -> DMap k (Compose ((,) (Bool, Event t ())) v)

@@ -140,3 +172,15 @@ mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do

140172 let voidResult' = fmapCheap (\_ -> ()) result'

141173 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))

142174 return (result0, result')

175+

176+--------------------------------------------------------------------------------

177+-- Deprecated functionality

178+--------------------------------------------------------------------------------

179+

180+-- | Deprecated

181+instance TransControl.MonadTransControl (PostBuildT t) where

182+ type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a

183+ {-# INLINABLE liftWith #-}

184+ liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT

185+ {-# INLINABLE restoreT #-}

186+ restoreT = TransControl.defaultRestoreT PostBuildT

src/Reflex/PostBuild/Class.hs+8

@@ -19,6 +19,8 @@ module Reflex.PostBuild.Class

1919import Reflex.Class

2020

2121import Control.Monad.Reader

22+import Control.Monad.State

23+import qualified Control.Monad.State.Strict as Strict

2224

2325-- | 'PostBuild' represents an action that is notified via an 'Event' when it

2426-- has finished executing. Note that the specific definition of "finished" is

@@ -32,3 +34,9 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where

3234

3335instance PostBuild t m => PostBuild t (ReaderT r m) where

3436 getPostBuild = lift getPostBuild

37+

38+instance PostBuild t m => PostBuild t (StateT s m) where

39+ getPostBuild = lift getPostBuild

40+

41+instance PostBuild t m => PostBuild t (Strict.StateT s m) where

42+ getPostBuild = lift getPostBuild

src/Reflex/Profiled.hsnew file+205

@@ -0,0 +1,205 @@

1+{-# LANGUAGE EmptyDataDecls #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE InstanceSigs #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+module Reflex.Profiled where

11+

12+import Control.Lens hiding (children)

13+import Control.Monad

14+import Control.Monad.Fix

15+import Control.Monad.Primitive

16+import Control.Monad.Reader

17+import Control.Monad.Ref

18+import Control.Monad.State.Strict (StateT, execStateT, modify)

19+import Data.Coerce

20+import Data.Dependent.Map (DMap, GCompare)

21+import Data.List

22+import Data.FastMutableIntMap

23+import Data.IORef

24+import Data.Map (Map)

25+import qualified Data.Map.Strict as Map

26+import Data.Monoid

27+import Data.Ord

28+import Data.Type.Coercion

29+import Foreign.Ptr

30+import GHC.Foreign

31+import GHC.IO.Encoding

32+import GHC.Stack

33+import Reflex.Class

34+import Reflex.PerformEvent.Class

35+import Reflex.Host.Class

36+

37+import System.IO.Unsafe

38+import Unsafe.Coerce

39+

40+data ProfiledTimeline t

41+

42+{-# NOINLINE profilingData #-}

43+profilingData :: IORef (Map (Ptr CostCentreStack) Int)

44+profilingData = unsafePerformIO $ newIORef Map.empty

45+

46+data CostCentreTree = CostCentreTree

47+ { _costCentreTree_ownEntries :: !Int

48+ , _costCentreTree_cumulativeEntries :: !Int

49+ , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)

50+ }

51+ deriving (Show, Eq, Ord)

52+

53+instance Monoid CostCentreTree where

54+ mempty = CostCentreTree 0 0 mempty

55+ CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb

56+

57+getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]

58+getCostCentreStack = go []

59+ where go l ccs = if ccs == nullPtr

60+ then return l

61+ else do

62+ cc <- ccsCC ccs

63+ parent <- ccsParent ccs

64+ go (cc : l) parent

65+

66+toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree

67+toCostCentreTree ccs n = do

68+ ccList <- getCostCentreStack ccs

69+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList

70+

71+getCostCentreTree :: IO CostCentreTree

72+getCostCentreTree = do

73+ vals <- readIORef profilingData

74+ mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)

75+

76+formatCostCentreTree :: CostCentreTree -> IO String

77+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []

78+ where go :: Int -> CostCentreTree -> StateT [String] IO ()

79+ go depth cct = do

80+ let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct

81+ indent = mconcat $ replicate depth " "

82+ forM_ children $ \(cc, childCct) -> do

83+ lbl <- liftIO $ peekCString utf8 =<< ccLabel cc

84+ mdl <- liftIO $ peekCString utf8 =<< ccModule cc

85+ loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc

86+ let description = mdl <> "." <> lbl <> " (" <> loc <> ")"

87+ modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)

88+ go (succ depth) childCct

89+

90+showProfilingData :: IO ()

91+showProfilingData = do

92+ putStr =<< formatCostCentreTree =<< getCostCentreTree

93+

94+writeProfilingData :: FilePath -> IO ()

95+writeProfilingData p = do

96+ writeFile p =<< formatCostCentreTree =<< getCostCentreTree

97+

98+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)

99+

100+profileEvent :: Reflex t => Event t a -> Event t a

101+profileEvent e = unsafePerformIO $ do

102+ stack <- getCurrentCCS e

103+ let f x = unsafePerformIO $ do

104+ modifyIORef' profilingData $ Map.insertWith (+) stack 1

105+ return $ return $ Just x

106+ return $ pushCheap f e

107+

108+--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs

109+

110+instance Reflex t => Reflex (ProfiledTimeline t) where

111+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }

112+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }

113+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }

114+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }

115+ type PushM (ProfiledTimeline t) = ProfiledM (PushM t)

116+ type PullM (ProfiledTimeline t) = ProfiledM (PullM t)

117+ never = Event_Profiled never

118+ constant = Behavior_Profiled . constant

119+ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

120+ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

121+ pull = Behavior_Profiled . pull . coerce

122+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)

123+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))

124+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)

125+ switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

126+ coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

127+ current (Dynamic_Profiled d) = coerce $ current d

128+ updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

129+ unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

130+ unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

131+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))

132+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))

133+ currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

134+ updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

135+ incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

136+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of

137+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

138+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of

139+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

140+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of

141+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

142+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))

143+ fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

144+

145+deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

146+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))

147+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))

148+

149+instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

150+ hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'

151+ holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'

152+ holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

153+ buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

154+ headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

155+

156+instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

157+ sample (Behavior_Profiled b) = ProfiledM $ sample b

158+

159+instance MonadTrans ProfiledM where

160+ lift = ProfiledM

161+

162+instance MonadIO m => MonadIO (ProfiledM m) where

163+ liftIO = lift . liftIO

164+

165+instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where

166+ type Performable (ProfiledM m) = Performable m

167+ performEvent_ = lift . performEvent_ . coerce

168+ performEvent = lift . fmap coerce . performEvent . coerce

169+

170+instance MonadRef m => MonadRef (ProfiledM m) where

171+ type Ref (ProfiledM m) = Ref m

172+ newRef = lift . newRef

173+ readRef = lift . readRef

174+ writeRef r = lift . writeRef r

175+

176+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where

177+ newEventWithTrigger = lift . fmap coerce . newEventWithTrigger

178+ newFanEventWithTrigger f = do

179+ es <- lift $ newFanEventWithTrigger f

180+ return $ EventSelector $ \k -> coerce $ select es k

181+

182+instance MonadReader r m => MonadReader r (ProfiledM m) where

183+ ask = lift ask

184+ local f (ProfiledM a) = ProfiledM $ local f a

185+ reader = lift . reader

186+

187+instance ReflexHost t => ReflexHost (ProfiledTimeline t) where

188+ type EventTrigger (ProfiledTimeline t) = EventTrigger t

189+ type EventHandle (ProfiledTimeline t) = EventHandle t

190+ type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)

191+

192+instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where

193+ subscribeEvent = lift . subscribeEvent . coerce

194+

195+instance PrimMonad m => PrimMonad (ProfiledM m) where

196+ type PrimState (ProfiledM m) = PrimState m

197+ primitive = lift . primitive

198+

199+instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where

200+ type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)

201+ fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r

202+ runHostFrame = lift . runHostFrame . coerce

203+

204+instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where

205+ readEvent = lift . fmap coerce . readEvent

src/Reflex/Pure.hs+15

@@ -34,6 +34,8 @@ import Control.Monad

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

3535import qualified Data.Dependent.Map as DMap

3636import Data.Functor.Identity

37+import Data.IntMap (IntMap)

38+import qualified Data.IntMap as IntMap

3739import Data.Maybe

3840import Data.MemoTrie

3941import Data.Monoid

@@ -125,6 +127,10 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

125127 eventCoercion Coercion = Coercion

126128 dynamicCoercion Coercion = Coercion

127129

130+ fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

131+

132+ mergeIntIncremental = mergeIntIncrementalImpl

133+

128134mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)

129135mergeIncrementalImpl i = Event $ \t ->

130136 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t

@@ -132,6 +138,13 @@ mergeIncrementalImpl i = Event $ \t ->

132138 then Nothing

133139 else Just results

134140

141+mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)

142+mergeIntIncrementalImpl i = Event $ \t ->

143+ let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t

144+ in if IntMap.null results

145+ then Nothing

146+ else Just results

147+

135148instance Functor (Dynamic (Pure t)) where

136149 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

137150 in (f cur, fmap f upd)

@@ -189,3 +202,5 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

189202 in case unEvent e lastTime of

190203 Nothing -> lastValue

191204 Just x -> fromMaybe lastValue $ apply x lastValue

205+

206+ headE = slowHeadE

src/Reflex/Query/Base.hs+2−1

@@ -268,7 +268,8 @@ instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (Qu

268268instance Requester t m => Requester t (QueryT t q m) where

269269 type Request (QueryT t q m) = Request m

270270 type Response (QueryT t q m) = Response m

271− withRequesting f = QueryT $ withRequesting $ unQueryT . f

271+ requesting = lift . requesting

272+ requesting_ = lift . requesting_

272273

273274instance EventWriter t w m => EventWriter t w (QueryT t q m) where

274275 tellEvent = lift . tellEvent

src/Reflex/Requester/Base.hs+310−47

@@ -1,16 +1,21 @@

11-- | This module provides 'RequesterT', the standard implementation of

22-- 'Requester'.

3+{-# LANGUAGE AllowAmbiguousTypes #-}

34{-# LANGUAGE BangPatterns #-}

45{-# LANGUAGE CPP #-}

6+{-# LANGUAGE EmptyDataDecls #-}

57{-# LANGUAGE ExistentialQuantification #-}

68{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE GADTs #-}

710{-# LANGUAGE GeneralizedNewtypeDeriving #-}

811{-# LANGUAGE MultiParamTypeClasses #-}

912{-# LANGUAGE Rank2Types #-}

13+{-# LANGUAGE RecursiveDo #-}

1014{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

1116{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE TypeOperators #-}

1218{-# LANGUAGE UndecidableInstances #-}

13−{-# LANGUAGE StandaloneDeriving #-}

1419#ifdef USE_REFLEX_OPTIMIZER

1520{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

1621#endif

@@ -18,11 +23,17 @@ module Reflex.Requester.Base

1823 ( RequesterT (..)

1924 , runRequesterT

2025 , runWithReplaceRequesterTWith

21− , sequenceDMapWithAdjustRequesterTWith

26+ , traverseIntMapWithKeyWithAdjustRequesterTWith

27+ , traverseDMapWithKeyWithAdjustRequesterTWith

28+ , RequesterData

29+ , RequesterDataKey

30+ , traverseRequesterData

31+ , requesterDataToList

32+ , singletonRequesterData

2233 ) where

2334

2435import Reflex.Class

25−import Reflex.EventWriter

36+import Reflex.Dynamic

2637import Reflex.Host.Class

2738import Reflex.PerformEvent.Class

2839import Reflex.PostBuild.Class

@@ -31,20 +42,190 @@ import Reflex.TriggerEvent.Class

3142

3243import Control.Monad.Exception

3344import Control.Monad.Identity

34−import Control.Monad.Primitive

3545import Control.Monad.Reader

3646import Control.Monad.Ref

3747import Control.Monad.State.Strict

48+import Data.Bits

3849import Data.Coerce

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

4051import qualified Data.Dependent.Map as DMap

52+import qualified Data.Some as Some

53+import Data.FastMutableIntMap

54+import Data.Functor.Compose

4155import Data.Functor.Misc

56+import Data.IntMap.Strict (IntMap)

57+import qualified Data.IntMap.Strict as IntMap

4258import Data.Map (Map)

59+import qualified Data.Map as Map

60+import Data.Monoid ((<>))

4361import Data.Unique.Tag

4462import Data.Some (Some)

63+import Data.Type.Equality

64+import Data.Proxy

65+

66+import GHC.Exts (Any)

67+import Unsafe.Coerce

68+

69+--TODO: Make this module type-safe

70+

71+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

72+

73+newtype RequesterData f = RequesterData (TagMap (Entry f))

74+

75+data RequesterDataKey a where

76+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

77+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

78+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

79+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

80+

81+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

82+singletonRequesterData rdk v = case rdk of

83+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

84+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

85+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

86+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

87+

88+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

89+requesterDataToList (RequesterData m) = do

90+ k :=> Entry e <- tagMapToList m

91+ case myKeyType k of

92+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

93+ MyTagType_Multi -> do

94+ (k', e') <- IntMap.toList e

95+ k'' :=> e'' <- requesterDataToList e'

96+ return $ RequesterDataKey_Multi k k' k'' :=> e''

97+ MyTagType_Multi2 -> do

98+ (k', e') <- Map.toList e

99+ (k'', e'') <- IntMap.toList e'

100+ k''' :=> e''' <- requesterDataToList e''

101+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

102+ MyTagType_Multi3 -> do

103+ (k', e') <- IntMap.toList e

104+ (k'', e'') <- IntMap.toList e'

105+ k''' :=> e''' <- requesterDataToList e''

106+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

107+

108+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

109+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

110+

111+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

112+tagMapToList (TagMap m) = fmap f $ IntMap.toList m

113+ where f :: (Int, Any) -> DSum MyTag f

114+ f (k, v) = MyTag k :=> ((unsafeCoerce :: Any -> f a) v)

115+

116+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

117+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

118+ where

119+ g :: Int -> Any -> t Any

120+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

121+

122+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

123+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

124+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

125+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

126+ go k (Entry request) = Entry <$> case myKeyType k of

127+ MyTagType_Single -> f request

128+ MyTagType_Multi -> traverse (traverseRequesterData f) request

129+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

130+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

131+

132+data MyTagType :: * -> * where

133+ MyTagType_Single :: MyTagType (Single a)

134+ MyTagType_Multi :: MyTagType Multi

135+ MyTagType_Multi2 :: MyTagType (Multi2 k)

136+ MyTagType_Multi3 :: MyTagType Multi3

137+

138+myKeyType :: MyTag x -> MyTagType x

139+myKeyType (MyTag k) = case k .&. 0x3 of

140+ 0x0 -> unsafeCoerce MyTagType_Single

141+ 0x1 -> unsafeCoerce MyTagType_Multi

142+ 0x2 -> unsafeCoerce MyTagType_Multi2

143+ 0x3 -> unsafeCoerce MyTagType_Multi3

144+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

145+

146+data Single a

147+data Multi

148+data Multi2 (k :: * -> *)

149+data Multi3

150+

151+class MyTagTypeOffset x where

152+ myTagTypeOffset :: proxy x -> Int

153+

154+instance MyTagTypeOffset (Single a) where

155+ myTagTypeOffset _ = 0x0

156+

157+instance MyTagTypeOffset Multi where

158+ myTagTypeOffset _ = 0x1

159+

160+instance MyTagTypeOffset (Multi2 k) where

161+ myTagTypeOffset _ = 0x2

162+

163+instance MyTagTypeOffset Multi3 where

164+ myTagTypeOffset _ = 0x3

165+

166+type family EntryContents request a where

167+ EntryContents request (Single a) = request a

168+ EntryContents request Multi = IntMap (RequesterData request)

169+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

170+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

171+

172+newtype Entry request x = Entry { unEntry :: EntryContents request x }

173+

174+{-# INLINE singleEntry #-}

175+singleEntry :: f a -> Entry f (Single a)

176+singleEntry = Entry

177+

178+{-# INLINE multiEntry #-}

179+multiEntry :: IntMap (RequesterData f) -> Entry f Multi

180+multiEntry = Entry

181+

182+{-# INLINE unMultiEntry #-}

183+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

184+unMultiEntry = unEntry

185+

186+-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

187+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

188+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

189+

190+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

191+

192+{-# INLINE castMyTagWrap #-}

193+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

194+castMyTagWrap = coerce

195+

196+instance GEq MyTag where

197+ (MyTag a) `geq` (MyTag b) =

198+ if a == b

199+ then Just $ unsafeCoerce Refl

200+ else Nothing

201+

202+instance GCompare MyTag where

203+ (MyTag a) `gcompare` (MyTag b) =

204+ case a `compare` b of

205+ LT -> GLT

206+ EQ -> unsafeCoerce GEQ

207+ GT -> GGT

208+

209+instance GEq (MyTagWrap f) where

210+ (MyTagWrap a) `geq` (MyTagWrap b) =

211+ if a == b

212+ then Just $ unsafeCoerce Refl

213+ else Nothing

214+

215+instance GCompare (MyTagWrap f) where

216+ (MyTagWrap a) `gcompare` (MyTagWrap b) =

217+ case a `compare` b of

218+ LT -> GLT

219+ EQ -> unsafeCoerce GEQ

220+ GT -> GGT

221+

222+data RequesterState t (request :: * -> *) = RequesterState

223+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

224+ , _requesterState_requests :: ![(Int, Event t Any)]

225+ }

45226

46227-- | A basic implementation of 'Requester'.

47−newtype RequesterT t request response m a = RequesterT { unRequesterT :: EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

228+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

48229 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

49230-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

50231#if MIN_VERSION_base(4,9,1)

@@ -64,22 +245,36 @@ deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request respo

64245

65246runRequesterT :: (Reflex t, Monad m)

66247 => RequesterT t request response m a

67− -> Event t (DMap (Tag (PrimState m)) response)

68− -> m (a, Event t (DMap (Tag (PrimState m)) request))

248+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

249+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

69250runRequesterT (RequesterT a) responses = do

70− (result, requests) <- runReaderT (runEventWriterT a) $ fan $

71− mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

72− return (result, requests)

251+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

252+ coerceEvent responses

253+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

73254

74−instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

255+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

75256 type Request (RequesterT t request response m) = request

76257 type Response (RequesterT t request response m) = response

77− withRequesting a = do

78− !t <- lift newTag --TODO: Fix this upstream

79− s <- RequesterT ask

80− (req, result) <- a $ select s $ WrapArg t

81− RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req

82− return result

258+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

259+ requesting_ = void . tagRequest . fmapCheap singleEntry

260+

261+{-# INLINE tagRequest #-}

262+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

263+tagRequest req = do

264+ old <- RequesterT get

265+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

266+ t = MyTagWrap n

267+ RequesterT $ put $ RequesterState

268+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

269+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

270+ }

271+ return t

272+

273+{-# INLINE responseFromTag #-}

274+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

275+responseFromTag (MyTagWrap t) = do

276+ responses :: EventSelectorInt t Any <- RequesterT ask

277+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

83278

84279instance MonadTrans (RequesterT t request response) where

85280 lift = RequesterT . lift . lift

@@ -101,34 +296,88 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT

101296

102297instance MonadReader r m => MonadReader r (RequesterT t request response m) where

103298 ask = lift ask

104− local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a

299+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

105300 reader = lift . reader

106301

107−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

108− runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

109− traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

110− traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

302+instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where

303+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

304+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

305+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

306+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

307+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

308+

309+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

310+requesting' = responseFromTag . castMyTagWrap <=< tagRequest

111311

112−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

312+{-# INLINABLE runWithReplaceRequesterTWith #-}

313+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

314+ , MonadFix m

315+ )

113316 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

114317 -> RequesterT t request response m a

115318 -> Event t (RequesterT t request response m b)

116319 -> RequesterT t request response m (a, Event t b)

117−runWithReplaceRequesterTWith f a0 a' =

118− let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'

119− -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

120− -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')

121− f' x y = do

122− r <- EventWriterT $ ask

123− unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

124− in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

125−

126−sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

320+runWithReplaceRequesterTWith f a0 a' = do

321+ rec na' <- numberOccurrencesFrom 1 a'

322+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

323+ let responses' = fanInt responses

324+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

325+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

326+ return (result0, fmapCheap (fst . snd) v')

327+

328+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

329+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

330+ ( Reflex t

331+ , MonadHold t m

332+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

333+ , Patch (p (Event t (IntMap (RequesterData request))))

334+ , Functor p

335+ , MonadFix m

336+ )

337+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

338+ -> IntMap (IntMap.Key, v)

339+ -> Event t (p (IntMap.Key, v))

340+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

341+ )

342+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

343+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

344+ -> (IntMap.Key -> v -> RequesterT t request response m v')

345+ -> IntMap v

346+ -> Event t (p v)

347+ -> RequesterT t request response m (IntMap v', Event t (p v'))

348+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

349+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

350+ let responses :: EventSelectorInt t (IntMap (RequesterData response))

351+ responses = fanInt $ fmapCheap unpack response

352+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

353+ unpack = unEntry

354+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

355+ pack = Entry

356+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

357+ f' k (n, v) = do

358+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

359+ return (fmapCheap (IntMap.singleton n) myRequests, result)

360+ ndm' <- numberOccurrencesFrom 1 dm'

361+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to MonadAdjust

362+ let result0 = fmap snd children0

363+ result' = fforCheap children' $ fmap snd

364+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))

365+ requests0 = fmap fst children0

366+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))

367+ requests' = fforCheap children' $ fmap fst

368+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

369+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

370+ requests <- holdIncremental requests0 requests'

371+ return (result0, result')

372+

373+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

374+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

127375 ( GCompare k

128376 , Reflex t

129377 , MonadHold t m

130− , PatchTarget (p' (Some k) (Event t (DMap (Tag (PrimState m)) request))) ~ Map (Some k) (Event t (DMap (Tag (PrimState m)) request))

131− , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))

378+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

379+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

380+ , MonadFix m

132381 )

133382 => (forall k' v1 v2. GCompare k'

134383 => (forall a. k' a -> v1 a -> m (v2 a))

@@ -136,21 +385,35 @@ sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

136385 -> Event t (p k' v1)

137386 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

138387 )

139− -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')

388+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

140389 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

141− -> (forall v2. p' (Some k) v2 -> [v2])

390+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

142391 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

143392 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

144393 -> DMap k v

145394 -> Event t (p k v)

146395 -> RequesterT t request response m (DMap k v', Event t (p k v'))

147−sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =

148− let base' :: forall v1 v2.

149− (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))

150− -> DMap k v1

151− -> Event t (p k v1)

152− -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k v2, Event t (p k v2))

153− base' f' x y = do

154− r <- EventWriterT ask

155− unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y

156− in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')

396+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

397+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

398+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

399+ responses = fanMap $ fmapCheap unpack response

400+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

401+ unpack = unEntry

402+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

403+ pack = Entry

404+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

405+ f' k (Compose (n, v)) = do

406+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))

407+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

408+ ndm' <- numberOccurrencesFrom 1 dm'

409+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

410+ let result0 = DMap.map (snd . getCompose) children0

411+ result' = fforCheap children' $ mapPatch $ snd . getCompose

412+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

413+ requests0 = weakenDMapWith (fst . getCompose) children0

414+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

415+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

416+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

417+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

418+ requests <- holdIncremental requests0 requests'

419+ return (result0, result')

src/Reflex/Requester/Class.hs+20−34

@@ -7,6 +7,7 @@

77{-# LANGUAGE FlexibleInstances #-}

88{-# LANGUAGE FunctionalDependencies #-}

99{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE RecursiveDo #-}

1011{-# LANGUAGE TypeFamilies #-}

1112{-# LANGUAGE UndecidableInstances #-}

1213#ifdef USE_REFLEX_OPTIMIZER

@@ -14,8 +15,7 @@

1415#endif

1516module Reflex.Requester.Class

1617 ( Requester (..)

17− , requesting

18− , requesting_

18+ , withRequesting

1919 , requestingIdentity

2020 ) where

2121

@@ -36,52 +36,38 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

3636 type Request m :: * -> *

3737 -- | The type of responses that this 'Requester' can receive

3838 type Response m :: * -> *

39− -- | Usually, end-user code should use 'requesting', 'requesting_', or

40− -- 'requestingIdentity'. For implementers of 'Requester', this function

41− -- provides a convenient way to define instances of the typeclass that

42− -- efficiently support the underlying operations without needing to use

43− -- 'Control.Monad.Fix.MonadFix'.

44− withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

39+ -- | Emit a request whenever the given 'Event' fires, and return responses in

40+ -- the resulting 'Event'.

41+ requesting :: Event t (Request m a) -> m (Event t (Response m a))

42+ -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

43+ requesting_ :: Event t (Request m a) -> m ()

44+

4545

4646instance Requester t m => Requester t (ReaderT r m) where

4747 type Request (ReaderT r m) = Request m

4848 type Response (ReaderT r m) = Response m

49− withRequesting f = do

50− r <- ask

51− lift $ withRequesting $ (`runReaderT` r) . f

49+ requesting = lift . requesting

50+ requesting_ = lift . requesting_

5251

5352instance Requester t m => Requester t (StateT s m) where

5453 type Request (StateT s m) = Request m

5554 type Response (StateT s m) = Response m

56− withRequesting f = do

57− old <- get

58− (result, new) <- lift $ withRequesting $ \x -> do

59− ((request, result), new) <- runStateT (f x) old

60− return (request, (result, new))

61− put new

62− return result

55+ requesting = lift . requesting

56+ requesting_ = lift . requesting_

6357

6458instance Requester t m => Requester t (Lazy.StateT s m) where

6559 type Request (Lazy.StateT s m) = Request m

6660 type Response (Lazy.StateT s m) = Response m

67− withRequesting f = do

68− old <- Lazy.get

69− (result, new) <- lift $ withRequesting $ \x -> do

70− ((request, result), new) <- Lazy.runStateT (f x) old

71− return (request, (result, new))

72− Lazy.put new

73− return result

74−

75−-- | Emit a request whenever the given 'Event' fires, and return responses in

76−-- the resulting 'Event'.

77−requesting :: Requester t m => Event t (Request m a) -> m (Event t (Response m a))

78−requesting req = withRequesting $ return . (,) req

79−

80−-- | Emit a request whenever the given 'Event' fires, and ignore all responses.

81−requesting_ :: Requester t m => Event t (Request m a) -> m ()

82−requesting_ req = withRequesting $ \_ -> return (req, ())

61+ requesting = lift . requesting

62+ requesting_ = lift . requesting_

8363

8464-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

8565-- before returning them. @Response m@ must be 'Identity'.

8666requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

8767requestingIdentity = fmap coerceEvent . requesting

68+

69+withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

70+withRequesting f = do

71+ rec response <- requesting request

72+ (request, result) <- f response

73+ return result

src/Reflex/Spider/Internal.hs+386−149

@@ -8,9 +8,7 @@

88{-# LANGUAGE FunctionalDependencies #-}

99{-# LANGUAGE GADTs #-}

1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11−#if defined(DEBUG) || defined(DEBUG_CYCLES)

1211{-# LANGUAGE LambdaCase #-}

13−#endif

1412{-# LANGUAGE MagicHash #-}

1513{-# LANGUAGE MultiParamTypeClasses #-}

1614{-# LANGUAGE MultiWayIf #-}

@@ -59,9 +57,12 @@ import Data.Proxy

5957import Data.These

6058import Data.Traversable

6159import Data.Word

60+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

61+import qualified Data.FastMutableIntMap as FastMutableIntMap

6262import GHC.Exts

6363import GHC.IORef (IORef (..))

6464import GHC.Stack

65+import Reflex.FastWeak

6566import Reflex.FunctorMaybe

6667import System.IO.Unsafe

6768import System.Mem.Weak

@@ -75,6 +76,8 @@ import Data.Monoid (mempty)

7576import Data.Tree (Forest, Tree (..), drawForest)

7677#endif

7778

79+import Data.FastWeakBag (FastWeakBag)

80+import qualified Data.FastWeakBag as FastWeakBag

7881import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

7982import qualified Data.WeakBag as WeakBag

8083#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -240,22 +243,57 @@ subscribeAndRead = unEvent

240243-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

241244-- caching; if the computation function is very cheap, this is (much) more

242245-- efficient than 'push'

243−{-# NOINLINE pushCheap #-}

246+{-# INLINE [1] pushCheap #-}

244247pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

245−pushCheap f e = Event $ \sub -> do

248+pushCheap !f e = Event $ \sub -> do

246249 (subscription, occ) <- subscribeAndRead e $ sub

247250 { subscriberPropagate = \a -> do

248− mb <- runComputeM $ f a

251+ mb <- f a

249252 mapM_ (subscriberPropagate sub) mb

250253 }

251− occ' <- join <$> mapM (runComputeM . f) occ

254+ occ' <- join <$> mapM f occ

252255 return (subscription, occ')

253256

257+-- | A subscriber that never triggers other 'Event's

258+{-# INLINE terminalSubscriber #-}

259+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a

260+terminalSubscriber p = Subscriber

261+ { subscriberPropagate = p

262+ , subscriberInvalidateHeight = \_ -> return ()

263+ , subscriberRecalculateHeight = \_ -> return ()

264+ }

265+

266+-- | Subscribe to an Event only for the duration of one occurrence

267+{-# INLINE subscribeAndReadHead #-}

268+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

269+subscribeAndReadHead e sub = do

270+ subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

271+ (subscription, occ) <- subscribeAndRead e $ sub

272+ { subscriberPropagate = \a -> do

273+ liftIO $ unsubscribe =<< readIORef subscriptionRef

274+ subscriberPropagate sub a

275+ }

276+ liftIO $ case occ of

277+ Nothing -> writeIORef subscriptionRef $! subscription

278+ Just _ -> unsubscribe subscription

279+ return (subscription, occ)

280+

281+--TODO: Make this lazy in its input event

282+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)

283+headE originalE = do

284+ parent <- liftIO $ newIORef $ Just originalE

285+ defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

286+ let clearParent = liftIO $ writeIORef parent Nothing

287+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent

288+ when (isJust occ) clearParent

289+ return $ Event $ \sub -> do

290+ liftIO (readIORef parent) >>= \case

291+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)

292+ Just e -> subscribeAndReadHead e sub

293+

254294data CacheSubscribed x a

255− = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))

256− , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))

295+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

257296 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

258− , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))

259297 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

260298 }

261299

@@ -263,62 +301,67 @@ data CacheSubscribed x a

263301-- repeatedly

264302--

265303--TODO: Try a caching strategy where we subscribe directly to the parent when

266−--there's only one subscriber, and then build our own WeakBag only when a second

304+--there's only one subscriber, and then build our own FastWeakBag only when a second

267305--subscriber joins

268−{-# NOINLINE cacheEvent #-}

269−cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

306+{-# NOINLINE [0] cacheEvent #-}

307+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

270308cacheEvent e =

271309#ifdef DEBUG_TRACE_EVENTS

272310 withStackOneLine $ \callSite -> Event $

273311#else

274312 Event $

275313#endif

276− let !mSubscribedRef = unsafeNewIORef e Nothing

314+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

315+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak

277316 in \sub -> {-# SCC "cacheEvent" #-} do

278317#ifdef DEBUG_TRACE_EVENTS

279318 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

280319#endif

281− mSubscribed <- liftIO $ readIORef mSubscribedRef

282− case mSubscribed of

283− Just subscribed -> liftIO $ do

284− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed

285− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

286− let es = EventSubscribed

287− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

288− , eventSubscribedRetained = toAny subscribed

289− }

290− return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

320+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

321+ Just subscribedTicket -> return subscribedTicket

291322 Nothing -> do

292− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

293− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

294− occRef <- liftIO $ newIORef undefined

323+ subscribers <- liftIO FastWeakBag.empty

324+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

295325 (parentSub, occ) <- subscribeAndRead e $ Subscriber

296326 { subscriberPropagate = \a -> do

297327 liftIO $ writeIORef occRef $ Just a

298328 scheduleClear occRef

299− propagate a subscribers

329+ propagateFast a subscribers

300330 , subscriberInvalidateHeight = \old -> do

301− WeakBag.traverse subscribers $ invalidateSubscriberHeight old

331+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

302332 , subscriberRecalculateHeight = \new -> do

303− WeakBag.traverse subscribers $ recalculateSubscriberHeight new

333+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

304334 }

305− liftIO $ writeIORef occRef occ

306− when (isJust occ) $ scheduleClear occRef

335+ when (isJust occ) $ do

336+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

337+ scheduleClear occRef

307338 let !subscribed = CacheSubscribed

308339 { _cacheSubscribed_subscribers = subscribers

309− , _cacheSubscribed_weakSelf = weakSelf

310340 , _cacheSubscribed_parent = parentSub

311− , _cacheSubscribed_cached = mSubscribedRef

312341 , _cacheSubscribed_occurrence = occRef

313342 }

314− liftIO $ writeIORef mSubscribedRef $ Just subscribed

315− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

316− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

317−

318−cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

319−cleanupCacheSubscribed self = do

320− unsubscribe $ _cacheSubscribed_parent self

321− writeIORef (_cacheSubscribed_cached self) Nothing

343+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

344+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

345+ return subscribedTicket

346+ liftIO $ do

347+ subscribed <- getFastWeakTicketValue subscribedTicket

348+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

349+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

350+ let es = EventSubscription

351+ { _eventSubscription_unsubscribe = do

352+ FastWeakBag.remove ticket

353+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

354+ when isEmpty $ do

355+ writeIORef mSubscribedRef emptyFastWeak

356+ unsubscribe $ _cacheSubscribed_parent subscribed

357+ touch ticket

358+ touch subscribedTicket

359+ , _eventSubscription_subscribed = EventSubscribed

360+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

361+ , eventSubscribedRetained = toAny subscribedTicket

362+ }

363+ }

364+ return (es, occ)

322365

323366subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

324367subscribe e s = fst <$> subscribeAndRead e s

@@ -352,7 +395,7 @@ eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

352395eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

353396

354397{-# INLINE subscribeCoincidenceInner #-}

355−subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)

398+subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)

356399subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

357400 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

358401 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

@@ -497,6 +540,13 @@ propagate a subscribers = withIncreasedDepth $ do

497540 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

498541 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

499542

543+-- | Propagate everything at the current height

544+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

545+propagateFast a subscribers = withIncreasedDepth $ do

546+ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

547+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

548+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

549+

500550--------------------------------------------------------------------------------

501551-- EventSubscribed

502552--------------------------------------------------------------------------------

@@ -595,7 +645,7 @@ walkInvalidHeightParents s0 = do

595645#endif

596646

597647{-# INLINE subscribeHoldEvent #-}

598−subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)

648+subscribeHoldEvent :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)

599649subscribeHoldEvent = subscribeAndRead . holdEvent

600650

601651--------------------------------------------------------------------------------

@@ -751,6 +801,7 @@ data EventEnv x

751801 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

752802 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

753803 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

804+ , eventEnvIntClears :: !(IORef [SomeIntClear])

754805 , eventEnvRootClears :: !(IORef [SomeRootClear])

755806 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

756807 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

@@ -835,6 +886,14 @@ instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

835886scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

836887scheduleClear r = defer $ SomeClear r

837888

889+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where

890+ {-# INLINE getDeferralQueue #-}

891+ getDeferralQueue = asksEventEnv eventEnvIntClears

892+

893+{-# INLINE scheduleIntClear #-}

894+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()

895+scheduleIntClear r = defer $ SomeIntClear r

896+

838897instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

839898 {-# INLINE getDeferralQueue #-}

840899 getDeferralQueue = asksEventEnv eventEnvRootClears

@@ -870,7 +929,7 @@ hold v0 e = do

870929 return h

871930

872931{-# INLINE getHoldEventSubscription #-}

873−getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)

932+getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)

874933getHoldEventSubscription h = do

875934 ep <- liftIO $ readIORef $ holdParent h

876935 case ep of

@@ -970,21 +1029,6 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

9701029-- EventM can do everything BehaviorM can, plus create holds

9711030newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

9721031

973−newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x], IORef [SomeDynInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

974−

975−instance Defer (SomeHoldInit x) (ComputeM x) where

976− getDeferralQueue = ComputeM $ asks fst

977−

978−instance Defer (SomeDynInit x) (ComputeM x) where

979− getDeferralQueue = ComputeM $ asks snd

980−

981−{-# INLINABLE runComputeM #-}

982−runComputeM :: (Defer (SomeHoldInit x) m, Defer (SomeDynInit x) m) => ComputeM x a -> m a

983−runComputeM (ComputeM a) = do

984− holds <- getDeferralQueue

985− dyns <- getDeferralQueue

986− liftIO $ runReaderT a (holds, dyns)

987−

9881032newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

9891033

9901034data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove

@@ -1111,7 +1155,7 @@ instance HasSpiderTimeline x => FunctorMaybe (Event x) where

11111155

11121156instance HasSpiderTimeline x => Align (Event x) where

11131157 nil = eventNever

1114− align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1158+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

11151159

11161160newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

11171161

@@ -1230,9 +1274,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

12301274 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

12311275 EQ -> a

12321276

1233−data SomeClear = forall a. SomeClear (IORef (Maybe a))

1277+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))

1278+

1279+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))

12341280

1235−data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1281+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))

12361282

12371283data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

12381284

@@ -1363,16 +1409,6 @@ getDynHold d = do

13631409zeroRef :: IORef Height

13641410zeroRef = unsafePerformIO $ newIORef zeroHeight

13651411

1366−type CanSubscribe x m =

1367− ( HasSpiderTimeline x

1368− , HasCurrentHeight x m

1369− , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1370− , Defer SomeClear m -- Wiping out event firings

1371− , Defer (SomeAssignment x) m -- Updating state

1372− , Defer (SomeResetCoincidence x) m

1373− , m ~ EventM x

1374− )

1375−

13761412getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

13771413getRootSubscribed k r sub = do

13781414 mSubscribed <- readIORef $ rootSubscribed r

@@ -1428,8 +1464,71 @@ cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribe

14281464subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

14291465subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

14301466

1467+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }

1468+

1469+data FanInt x a = FanInt

1470+ { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1471+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1472+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1473+ }

1474+

1475+newFanInt :: IO (FanInt x a)

1476+newFanInt = do

1477+ subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1478+ subscriptionRef <- newIORef $ error "fanInt: no subscription"

1479+ occRef <- newIORef $ error "fanInt: no occurrence"

1480+ return $ FanInt

1481+ { _fanInt_subscribers = subscribers

1482+ , _fanInt_subscriptionRef = subscriptionRef

1483+ , _fanInt_occRef = occRef

1484+ }

1485+

1486+{-# NOINLINE unsafeNewFanInt #-}

1487+unsafeNewFanInt :: b -> FanInt x a

1488+unsafeNewFanInt b = unsafePerformIO $ do

1489+ touch b

1490+ newFanInt

1491+

1492+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1493+fanInt p =

1494+ let self = unsafeNewFanInt p

1495+ in EventSelectorInt $ \k -> Event $ \sub -> do

1496+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1497+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1498+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1499+ { subscriberPropagate = \m -> do

1500+ liftIO $ writeIORef (_fanInt_occRef self) m

1501+ scheduleIntClear $ _fanInt_occRef self

1502+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

1503+ FastWeakBag.traverse b $ \s -> do

1504+ subscriberPropagate s v

1505+ , subscriberInvalidateHeight = \old -> do

1506+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1507+ FastWeakBag.traverse b $ \s -> do

1508+ subscriberInvalidateHeight s old

1509+ , subscriberRecalculateHeight = \new -> do

1510+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1511+ FastWeakBag.traverse b $ \s -> do

1512+ subscriberRecalculateHeight s new

1513+ }

1514+ liftIO $ do

1515+ writeIORef (_fanInt_subscriptionRef self) subscription

1516+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc

1517+ scheduleIntClear $ _fanInt_occRef self

1518+ liftIO $ do

1519+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case

1520+ Nothing -> do

1521+ b <- FastWeakBag.empty

1522+ FastMutableIntMap.insert (_fanInt_subscribers self) k b

1523+ return b

1524+ Just b -> return b

1525+ t <- liftIO $ FastWeakBag.insert sub b

1526+ currentOcc <- readIORef (_fanInt_occRef self)

1527+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1528+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1529+

14311530{-# INLINABLE getFanSubscribed #-}

1432−getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)

1531+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)

14331532getFanSubscribed k f sub = do

14341533 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

14351534 case mSubscribed of

@@ -1488,7 +1587,7 @@ subscribeFanSubscribed k subscribed sub = do

14881587 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

14891588

14901589{-# INLINABLE getSwitchSubscribed #-}

1491−getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)

1590+getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)

14921591getSwitchSubscribed s sub = do

14931592 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

14941593 case mSubscribed of

@@ -1544,7 +1643,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBa

15441643subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

15451644

15461645{-# INLINABLE getCoincidenceSubscribed #-}

1547−getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

1646+getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

15481647getCoincidenceSubscribed c sub = do

15491648 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

15501649 case mSubscribed of

@@ -1607,7 +1706,7 @@ mergeWithMove d = cacheEvent (mergeCheapWithMove d)

16071706

16081707{-# INLINE [1] mergeCheap #-}

16091708mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1610−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1709+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

16111710 where

16121711 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

16131712 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1642,7 +1741,7 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

16421741

16431742{-# INLINE [1] mergeCheapWithMove #-}

16441743mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1645−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1744+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

16461745 where

16471746 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

16481747 updateMe subscriber heightBagRef oldParents p = do

@@ -1700,78 +1799,108 @@ type MergeDestroyFunc k s

17001799 = DMap k s

17011800 -> IO ()

17021801

1802+data Merge x k s = Merge

1803+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

1804+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

1805+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1806+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))

1807+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

1808+ }

1809+

1810+invalidateMergeHeight :: Merge x k s -> IO ()

1811+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1812+

1813+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1814+invalidateMergeHeight' heightRef sub = do

1815+ oldHeight <- readIORef heightRef

1816+ when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1817+ writeIORef heightRef $! invalidHeight

1818+ subscriberInvalidateHeight sub oldHeight

1819+

1820+

1821+revalidateMergeHeight :: Merge x k s -> IO ()

1822+revalidateMergeHeight m = do

1823+ currentHeight <- readIORef $ _merge_heightRef m

1824+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1825+ heights <- readIORef $ _merge_heightBagRef m

1826+ parents <- readIORef $ _merge_parentsRef m

1827+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1828+ case heightBagSize heights `compare` DMap.size parents of

1829+ LT -> return ()

1830+ EQ -> do

1831+ let height = succHeight $ heightBagMax heights

1832+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1833+ writeIORef (_merge_heightRef m) $! height

1834+ subscriberRecalculateHeight (_merge_sub m) height

1835+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

1836+

1837+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

1838+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1839+ vals <- liftIO $ readIORef $ _merge_accumRef m

1840+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

1841+ --TODO: Assert that m is not empty

1842+ subscriberPropagate (_merge_sub m) vals

1843+

1844+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a

1845+mergeSubscriber m getKey = Subscriber

1846+ { subscriberPropagate = \a -> do

1847+ oldM <- liftIO $ readIORef $ _merge_accumRef m

1848+ k <- getKey

1849+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1850+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1851+ liftIO $ writeIORef (_merge_accumRef m) $! newM

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

1853+ height <- liftIO $ readIORef $ _merge_heightRef m

1854+ --TODO: assertions about height

1855+ currentHeight <- getCurrentHeight

1856+ when (height <= currentHeight) $ do

1857+ if height /= invalidHeight

1858+ then do

1859+ myStack <- liftIO $ whoCreatedIORef undefined --TODO

1860+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1861+ else liftIO $ do

1862+#ifdef DEBUG_CYCLES

1863+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1864+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1865+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1866+#else

1867+ let cycleInfo = ""

1868+#endif

1869+ error $ "Causality loop found" <> cycleInfo

1870+ scheduleMergeSelf m height

1871+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1872+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

1873+ invalidateMergeHeight m

1874+ , subscriberRecalculateHeight = \new -> do

1875+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new

1876+ revalidateMergeHeight m

1877+ }

1878+

1879+--TODO: Be able to run as much of this as possible promptly

1880+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x

1881+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1882+ where updateMe = do

1883+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1884+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

1885+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1886+ return subscriptionsToKill

1887+

17031888{-# INLINE mergeCheap' #-}

1704−mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> (DMap k s -> Int) -> Dynamic x p -> Event x (DMap k Identity)

1705−mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do

1889+mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)

1890+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

17061891 initialParents <- readBehaviorUntracked $ dynamicCurrent d

17071892 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

17081893 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

17091894 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

17101895 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1711− let scheduleSelf height = scheduleMerge' height heightRef $ do

1712− m <- liftIO $ readIORef accumRef

1713− liftIO $ writeIORef accumRef $! DMap.empty

1714− --TODO: Assert that m is not empty

1715− subscriberPropagate sub m

1716− invalidateMyHeight = do

1717− oldHeight <- readIORef heightRef

1718− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1719− writeIORef heightRef $! invalidHeight

1720− subscriberInvalidateHeight sub oldHeight

1721− revalidateMyHeight = do

1722− currentHeight <- readIORef heightRef

1723− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1724− heights <- readIORef heightBagRef

1725− parents <- readIORef parentsRef

1726− -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1727− case heightBagSize heights `compare` numParents parents of

1728− LT -> return ()

1729− EQ -> do

1730− let height = succHeight $ heightBagMax heights

1731− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1732− writeIORef heightRef $! height

1733− subscriberRecalculateHeight sub height

1734− GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (numParents parents) <> ") for Merge"

1735− subscriber :: forall a. EventM x (k a) -> Subscriber x a

1736− subscriber getKey = Subscriber

1737− { subscriberPropagate = \a -> do

1738− oldM <- liftIO $ readIORef accumRef

1739− k <- getKey

1740− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1741− tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1742− liftIO $ writeIORef accumRef $! newM

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

1744− height <- liftIO $ readIORef heightRef

1745− --TODO: assertions about height

1746− currentHeight <- getCurrentHeight

1747− when (height <= currentHeight) $ do

1748− if height /= invalidHeight

1749− then do

1750− myStack <- liftIO $ whoCreatedIORef undefined --TODO

1751− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1752− else liftIO $ do

1753−#ifdef DEBUG_CYCLES

1754− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1755− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1756− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1757−#else

1758− let cycleInfo = ""

1759−#endif

1760− error $ "Causality loop found" <> cycleInfo

1761− scheduleSelf height

1762− , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1763− modifyIORef' heightBagRef $ heightBagRemove old

1764− invalidateMyHeight

1765− , subscriberRecalculateHeight = \new -> do

1766− modifyIORef' heightBagRef $ heightBagAdd new

1767− revalidateMyHeight

1896+ let m = Merge

1897+ { _merge_parentsRef = parentsRef

1898+ , _merge_heightBagRef = heightBagRef

1899+ , _merge_heightRef = heightRef

1900+ , _merge_sub = sub

1901+ , _merge_accumRef = accumRef

17681902 }

1769− let updateMe x = do

1770− oldParents <- liftIO $ readIORef parentsRef

1771− (subscriptionsToKill, newParents) <- updateFunc subscriber heightBagRef oldParents x

1772− liftIO $ writeIORef parentsRef $! newParents

1773− return subscriptionsToKill

1774− (dm, heights, initialParentState) <- getInitialSubscribers initialParents subscriber

1903+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

17751904 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

17761905 myHeight = if invalidHeight `elem` heights

17771906 then invalidHeight

@@ -1781,9 +1910,7 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

17811910 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

17821911 else (Nothing, dm)

17831912 unless (DMap.null accum) $ do

1784− scheduleSelf myHeight

1785− occRef <- liftIO $ newIORef occ

1786− when (isJust occ) $ scheduleClear occRef

1913+ scheduleMergeSelf m myHeight

17871914 liftIO $ writeIORef accumRef $! accum

17881915 liftIO $ writeIORef heightRef $! myHeight

17891916 liftIO $ writeIORef heightBagRef $! myHeightBag

@@ -1793,12 +1920,12 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

17931920 let s = Subscriber

17941921 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

17951922 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1796− defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1923+ defer $ updateMerge m updateFunc a

17971924 , subscriberInvalidateHeight = \_ -> return ()

17981925 , subscriberRecalculateHeight = \_ -> return ()

17991926 }

18001927 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1801− forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

1928+ forM_ change $ \c -> defer $ updateMerge m updateFunc c

18021929 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

18031930 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

18041931 -- its subscription.

@@ -1808,6 +1935,106 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

18081935 , occ

18091936 )

18101937

1938+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1939+mergeInt = cacheEvent . mergeIntCheap

1940+

1941+{-# INLINABLE mergeIntCheap #-}

1942+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1943+mergeIntCheap d = Event $ \sub -> do

1944+ initialParents <- readBehaviorUntracked $ dynamicCurrent d

1945+ accum <- liftIO $ FastMutableIntMap.newEmpty

1946+ heightRef <- liftIO $ newIORef zeroHeight

1947+ heightBagRef <- liftIO $ newIORef heightBagEmpty

1948+ parents <- liftIO $ FastMutableIntMap.newEmpty

1949+ let scheduleSelf = do

1950+ height <- liftIO $ readIORef $ heightRef

1951+ scheduleMerge' height heightRef $ do

1952+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

1953+ subscriberPropagate sub vals

1954+ invalidateMyHeight = do

1955+ invalidateMergeHeight' heightRef sub

1956+ recalculateMyHeight = do

1957+ currentHeight <- readIORef heightRef

1958+ when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

1959+ heights <- readIORef heightBagRef

1960+ numParents <- FastMutableIntMap.size parents

1961+ case heightBagSize heights `compare` numParents of

1962+ LT -> return ()

1963+ EQ -> do

1964+ let height = succHeight $ heightBagMax heights

1965+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1966+ writeIORef heightRef $! height

1967+ subscriberRecalculateHeight sub height

1968+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

1969+ mySubscriber k = Subscriber

1970+ { subscriberPropagate = \a -> do

1971+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

1972+ liftIO $ FastMutableIntMap.insert accum k a

1973+ when wasEmpty scheduleSelf

1974+ , subscriberInvalidateHeight = \old -> do

1975+ modifyIORef' heightBagRef $ heightBagRemove old

1976+ invalidateMyHeight

1977+ , subscriberRecalculateHeight = \new -> do

1978+ modifyIORef' heightBagRef $ heightBagAdd new

1979+ recalculateMyHeight

1980+ }

1981+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do

1982+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k

1983+ liftIO $ do

1984+ forM_ parentOcc $ FastMutableIntMap.insert accum k

1985+ FastMutableIntMap.insert parents k subscription

1986+ height <- getEventSubscribedHeight parentSubd

1987+ if height == invalidHeight

1988+ then writeIORef heightRef invalidHeight

1989+ else do

1990+ modifyIORef' heightBagRef $ heightBagAdd height

1991+ modifyIORef' heightRef $ \oldHeight ->

1992+ if oldHeight == invalidHeight

1993+ then invalidHeight

1994+ else max (succHeight height) oldHeight

1995+ myHeight <- liftIO $ readIORef heightRef

1996+ currentHeight <- getCurrentHeight

1997+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

1998+ occ <- if currentHeight >= myHeight -- If we should have fired by now

1999+ then if isEmpty

2000+ then return Nothing

2001+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2002+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2003+ return Nothing

2004+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2005+ defer $ SomeMergeInit $ do

2006+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2007+ where

2008+ u = do

2009+ let f k newParent = do

2010+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k

2011+ newParentHeight <- liftIO $ getEventSubscribedHeight subd

2012+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

2013+ return subscription

2014+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a

2015+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2016+ liftIO $ for_ oldParents $ \oldParent -> do

2017+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2018+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2019+ return $ IntMap.elems oldParents

2020+ let s = Subscriber

2021+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2022+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2023+ defer $ updateMe a

2024+ , subscriberInvalidateHeight = \_ -> return ()

2025+ , subscriberRecalculateHeight = \_ -> return ()

2026+ }

2027+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2028+ forM_ change $ \c -> defer $ updateMe c

2029+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2030+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2031+ -- its subscription.

2032+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2033+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2034+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2035+ , occ

2036+ )

2037+

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

18122039

18132040fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

@@ -1847,13 +2074,14 @@ newEventEnv = do

18472074 mergeInitRef <- newIORef []

18482075 heightRef <- newIORef zeroHeight

18492076 toClearRef <- newIORef []

2077+ toClearIntRef <- newIORef []

18502078 toClearRootRef <- newIORef []

18512079 coincidenceInfosRef <- newIORef []

18522080 delayedRef <- newIORef IntMap.empty

1853− return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

2081+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef

18542082

18552083clearEventEnv :: EventEnv x -> IO ()

1856−clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

2084+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

18572085 writeIORef toAssignRef []

18582086 writeIORef holdInitRef []

18592087 writeIORef dynInitRef []

@@ -1861,6 +2089,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

18612089 writeIORef mergeInitRef []

18622090 writeIORef heightRef zeroHeight

18632091 writeIORef toClearRef []

2092+ writeIORef toClearIntRef []

18642093 writeIORef toClearRootRef []

18652094 writeIORef coincidenceInfosRef []

18662095 writeIORef delayedRef IntMap.empty

@@ -1876,6 +2105,8 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

18762105 result <- runEventM go

18772106 toClear <- readIORef $ eventEnvClears env

18782107 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

2108+ toClearInt <- readIORef $ eventEnvIntClears env

2109+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty

18792110 toClearRoot <- readIORef $ eventEnvRootClears env

18802111 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

18812112 toAssign <- readIORef $ eventEnvAssignments env

@@ -2070,6 +2301,8 @@ withSpiderTimeline k = do

20702301

20712302newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

20722303

2304+type ComputeM = EventM

2305+

20732306newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

20742307

20752308#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -2122,6 +2355,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

21222355 eventCoercion Coercion = Coercion

21232356 behaviorCoercion Coercion = Coercion

21242357 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2358+ {-# INLINABLE mergeIntIncremental #-}

2359+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2360+ {-# INLINABLE fanInt #-}

2361+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

21252362#endif

21262363

21272364data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

src/Reflex/Spider/SpiderTimeline.include.hs+21−1

@@ -18,6 +18,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

1818 holdIncremental = holdIncrementalSpiderEventM

1919 {-# INLINABLE buildDynamic #-}

2020 buildDynamic = buildDynamicSpiderEventM

21+ {-# INLINABLE headE #-}

22+ headE = R.slowHeadE

23+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2124

2225instance (

2326#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -30,6 +33,8 @@ instance (

3033instance (

3134#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

3235 x ~ Global

36+#else

37+ HasSpiderTimeline x

3338#endif

3439 ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

3540 {-# INLINABLE sample #-}

@@ -44,6 +49,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

4449 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

4550 {-# INLINABLE buildDynamic #-}

4651 buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

52+ {-# INLINABLE headE #-}

53+ headE = R.slowHeadE

54+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

4755

4856instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

4957 {-# INLINE return #-}

@@ -55,6 +63,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

5563 {-# INLINE fail #-}

5664 fail _ = error "Dynamic does not support 'fail'"

5765

66+{-# INLINABLE newJoinDyn #-}

5867newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

5968newJoinDyn d =

6069 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

@@ -66,12 +75,16 @@ newJoinDyn d =

6675

6776instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

6877 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

78+ x <$ _ = pure x

6979

7080instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

7181 pure = SpiderDynamic . dynamicConst

82+#if MIN_VERSION_base(4,10,0)

83+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)

84+#endif

7285 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

7386 _ *> b = b

74− a <* _ = a

87+ a <* _ = a --TODO: The semantics of *>, <*, and <$ might not be quite right - they drop changes

7588

7689holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

7790holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

@@ -94,6 +107,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

94107 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

95108 {-# INLINABLE buildDynamic #-}

96109 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

110+ {-# INLINABLE headE #-}

111+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

97112

98113instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

99114 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

@@ -107,6 +122,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

107122 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

108123 {-# INLINABLE buildDynamic #-}

109124 buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

125+ {-# INLINABLE headE #-}

126+ headE = R.slowHeadE

127+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

110128

111129instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

112130 {-# INLINABLE sample #-}

@@ -125,6 +143,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

125143 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

126144 {-# INLINABLE buildDynamic #-}

127145 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

146+ {-# INLINABLE headE #-}

147+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

128148

129149--------------------------------------------------------------------------------

130150-- Deprecated items

src/Reflex/TriggerEvent/Base.hs+6

@@ -114,10 +114,16 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

114114 holdDyn v0 v' = lift $ holdDyn v0 v'

115115 {-# INLINABLE holdIncremental #-}

116116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117+ {-# INLINABLE buildDynamic #-}

118+ buildDynamic a0 = lift . buildDynamic a0

119+ {-# INLINABLE headE #-}

120+ headE = lift . headE

117121

118122instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

119123 {-# INLINABLE runWithReplace #-}

120124 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

125+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

126+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

121127 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

122128 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

123129 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

src/Reflex/TriggerEvent/Class.hs+12

@@ -11,6 +11,8 @@ module Reflex.TriggerEvent.Class

1111import Reflex.Class

1212

1313import Control.Monad.Reader

14+import Control.Monad.State

15+import qualified Control.Monad.State.Strict as Strict

1416

1517--TODO: Shouldn't have IO hard-coded

1618-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -36,3 +38,13 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

3638 newTriggerEvent = lift newTriggerEvent

3739 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

3840 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

41+

42+instance TriggerEvent t m => TriggerEvent t (StateT s m) where

43+ newTriggerEvent = lift newTriggerEvent

44+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

45+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

46+

47+instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

48+ newTriggerEvent = lift newTriggerEvent

49+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

50+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

test/Reflex/Plan/Pure.hs+1

@@ -40,6 +40,7 @@ instance MonadHold (Pure Int) PurePlan where

4040 holdDyn initial = liftPlan . holdDyn initial

4141 holdIncremental initial = liftPlan . holdIncremental initial

4242 buildDynamic getInitial = liftPlan . buildDynamic getInitial

43+ headE = liftPlan . headE

4344

4445instance MonadSample (Pure Int) PurePlan where

4546 sample = liftPlan . sample