fe21a50 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

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

fe21a50Ryan Trinkle9 years ago

reflex.cabal+11−1

compare with develop

unifiedsplit

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

49 MemoTrie == 0.6.*,

50 base >= 4.7 && < 4.11,

51 bifunctors >= 5.2 && < 5.5,

52+ comonad,

52 containers == 0.5.*,

53 containers == 0.5.*,

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

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

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

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

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

72 Data.AppendMap,

73 Data.AppendMap,

73 Data.Functor.Misc,

74 Data.Functor.Misc,

74 Data.WeakBag,

75 Data.WeakBag,

76+ Data.FastWeakBag,

77+ Data.FastMutableIntMap,

75 Reflex,

78 Reflex,

76 Reflex.Class,

79 Reflex.Class,

77 Reflex.EventWriter,

80 Reflex.EventWriter,

78 Reflex.Dynamic,

81 Reflex.Dynamic,

79 Reflex.Dynamic.Uniq,

82 Reflex.Dynamic.Uniq,

80 Reflex.DynamicWriter,

83 Reflex.DynamicWriter,

84+ Reflex.FastWeak,

81 Reflex.FunctorMaybe,

85 Reflex.FunctorMaybe,

82 Reflex.Host.Class,

86 Reflex.Host.Class,

83 Reflex.Patch,

87 Reflex.Patch,

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

92 Reflex.PerformEvent.Class,

96 Reflex.PerformEvent.Class,

93 Reflex.PostBuild.Base,

97 Reflex.PostBuild.Base,

94 Reflex.PostBuild.Class,

98 Reflex.PostBuild.Class,

99+ Reflex.Profiled,

95 Reflex.Query.Base,

100 Reflex.Query.Base,

96 Reflex.Query.Class,

101 Reflex.Query.Class,

97 Reflex.Requester.Base,

102 Reflex.Requester.Base,

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

100 Reflex.Spider.Internal,

105 Reflex.Spider.Internal,

101 Reflex.Widget.Basic

106 Reflex.Widget.Basic

102

107

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

104 ghc-prof-options: -fprof-auto

109 ghc-prof-options: -fprof-auto

105

110

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

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

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

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

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

138 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

143 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

139

144

145+ if impl(ghcjs)

146+ build-depends: ghcjs-base

147+

140test-suite semantics

148test-suite semantics

141 type: exitcode-stdio-1.0

149 type: exitcode-stdio-1.0

142 main-is: semantics.hs

150 main-is: semantics.hs

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

183 , hlint

191 , hlint

184 if impl(ghcjs)

192 if impl(ghcjs)

185 buildable: False

193 buildable: False

194+ buildable: False

186

195

187test-suite EventWriterT

196test-suite EventWriterT

188 type: exitcode-stdio-1.0

197 type: exitcode-stdio-1.0

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

208 , transformers

217 , transformers

209 , reflex

218 , reflex

210 , ref-tf

219 , ref-tf

220+ buildable: False

211

221

212test-suite QueryT

222test-suite QueryT

213 type: exitcode-stdio-1.0

223 type: exitcode-stdio-1.0

src/Data/AppendMap.hs+1−1

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

26import Data.Set (Set)

27import Data.Typeable

28import GHC.Generics (Generic)

29−import Reflex (FunctorMaybe (..))

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

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

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

7{-# LANGUAGE KindSignatures #-}

8{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PatternSynonyms #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

src/Reflex.hs+1

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

17import Reflex.PerformEvent.Class as X

18import Reflex.PostBuild.Base as X

19import Reflex.PostBuild.Class as X

20+import Reflex.Profiled as X

20import Reflex.Query.Base as X

21import Reflex.Query.Base as X

21import Reflex.Query.Class as X

22import Reflex.Query.Class as X

22import Reflex.Requester.Base as X

23import Reflex.Requester.Base as X

src/Reflex/Class.hs+167−46

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

29 ( module Reflex.Patch

30 -- * Primitives

31 , Reflex (..)

32+ , mergeInt

32 , coerceBehavior

33 , coerceBehavior

33 , coerceEvent

34 , coerceEvent

34 , coerceDynamic

35 , coerceDynamic

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

36 , MonadHold (..)

37 , MonadHold (..)

37 -- ** 'fan'-related types

38 -- ** 'fan'-related types

38 , EventSelector (..)

39 , EventSelector (..)

40+ , EventSelectorInt (..)

39 -- ** 'Incremental'-related types

41 -- ** 'Incremental'-related types

40 -- * Convenience functions

42 -- * Convenience functions

41 , constDyn

43 , constDyn

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

76 , zipDynWith

78 , zipDynWith

77 -- ** Accumulating state

79 -- ** Accumulating state

78 , Accumulator (..)

80 , 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

79 , mapAccum_

97 , mapAccum_

80 , mapAccumM_

98 , mapAccumM_

81 , mapAccumMaybe_

99 , mapAccumMaybe_

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

83 , zipListWithEvent

101 , zipListWithEvent

84 , numberOccurrences

102 , numberOccurrences

85 , numberOccurrencesFrom

103 , numberOccurrencesFrom

104+ , numberOccurrencesFrom_

86 , (<@>)

105 , (<@>)

87 , (<@)

106 , (<@)

88− , headE

89 , tailE

107 , tailE

90 , headTailE

108 , headTailE

91 , takeWhileE

109 , takeWhileE

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

120 , tagCheap

138 , tagCheap

121 , mergeWithCheap

139 , mergeWithCheap

122 , mergeWithCheap'

140 , mergeWithCheap'

141+ -- * Slow, but general, implementations

142+ , slowHeadE

123#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

143#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

124 , Spider

144 , Spider

125 , SpiderEnv

145 , SpiderEnv

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

174import Data.Functor.Constant

194import Data.Functor.Constant

175import Data.Functor.Misc

195import Data.Functor.Misc

176import Data.Functor.Plus

196import Data.Functor.Plus

197+import Data.IntMap.Strict (IntMap)

198+import qualified Data.IntMap.Strict as IntMap

177import Data.List.NonEmpty (NonEmpty (..))

199import Data.List.NonEmpty (NonEmpty (..))

178import Data.Map (Map)

200import Data.Map (Map)

179import Data.Maybe

201import Data.Maybe

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

185import Data.Type.Coercion

207import Data.Type.Coercion

186import Reflex.FunctorMaybe

208import Reflex.FunctorMaybe

187import Reflex.Patch

209import Reflex.Patch

210+import Data.FastMutableIntMap (PatchIntMap)

188

211

189#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

212#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

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

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

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

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

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

301 -- occurrence type

324 -- occurrence type

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

325 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

303#endif

328#endif

304

329

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+

305#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

334#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

306instance t ~ SpiderTimeline Global => Reflex t where

335instance t ~ SpiderTimeline Global => Reflex t where

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

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

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

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

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

432 holdIncremental v0 = lift . holdIncremental v0

461 holdIncremental v0 = lift . holdIncremental v0

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

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

463+ {-

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

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

435 buildDynamic getV0 = lift . buildDynamic getV0

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

436

477

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

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

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

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

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

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

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

449 }

490 }

450

491

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

493+

451--------------------------------------------------------------------------------

494--------------------------------------------------------------------------------

452-- Instances

495-- Instances

453--------------------------------------------------------------------------------

496--------------------------------------------------------------------------------

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

460 holdDyn a0 = lift . holdDyn a0

503 holdDyn a0 = lift . holdDyn a0

461 holdIncremental a0 = lift . holdIncremental a0

504 holdIncremental a0 = lift . holdIncremental a0

462 buildDynamic a0 = lift . buildDynamic a0

505 buildDynamic a0 = lift . buildDynamic a0

506+ headE = lift . headE

463

507

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

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

465 sample = lift . sample

509 sample = lift . sample

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

469 holdDyn a0 = lift . holdDyn a0

513 holdDyn a0 = lift . holdDyn a0

470 holdIncremental a0 = lift . holdIncremental a0

514 holdIncremental a0 = lift . holdIncremental a0

471 buildDynamic a0 = lift . buildDynamic a0

515 buildDynamic a0 = lift . buildDynamic a0

516+ headE = lift . headE

472

517

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

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

474 sample = lift . sample

519 sample = lift . sample

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

478 holdDyn a0 = lift . holdDyn a0

523 holdDyn a0 = lift . holdDyn a0

479 holdIncremental a0 = lift . holdIncremental a0

524 holdIncremental a0 = lift . holdIncremental a0

480 buildDynamic a0 = lift . buildDynamic a0

525 buildDynamic a0 = lift . buildDynamic a0

526+ headE = lift . headE

481

527

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

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

483 sample = lift . sample

529 sample = lift . sample

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

486 hold a0 = lift . hold a0

532 hold a0 = lift . hold a0

487 holdDyn a0 = lift . holdDyn a0

533 holdDyn a0 = lift . holdDyn a0

488 holdIncremental a0 = lift . holdIncremental a0

534 holdIncremental a0 = lift . holdIncremental a0

535+ buildDynamic a0 = lift . buildDynamic a0

536+ headE = lift . headE

489

537

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

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

491 sample = lift . sample

539 sample = lift . sample

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

494 hold a0 = lift . hold a0

542 hold a0 = lift . hold a0

495 holdDyn a0 = lift . holdDyn a0

543 holdDyn a0 = lift . holdDyn a0

496 holdIncremental a0 = lift . holdIncremental a0

544 holdIncremental a0 = lift . holdIncremental a0

545+ buildDynamic a0 = lift . buildDynamic a0

546+ headE = lift . headE

497

547

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

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

499 sample = lift . sample

549 sample = lift . sample

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

502 hold a0 = lift . hold a0

552 hold a0 = lift . hold a0

503 holdDyn a0 = lift . holdDyn a0

553 holdDyn a0 = lift . holdDyn a0

504 holdIncremental a0 = lift . holdIncremental a0

554 holdIncremental a0 = lift . holdIncremental a0

555+ buildDynamic a0 = lift . buildDynamic a0

556+ headE = lift . headE

505

557

506--------------------------------------------------------------------------------

558--------------------------------------------------------------------------------

507-- Convenience functions

559-- Convenience functions

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

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

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

603 {-# INLINE fmap #-}

655 {-# INLINE fmap #-}

604 fmap f = fmapMaybe $ Just . f

656 fmap f = fmapMaybe $ Just . f

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

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

605

659

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

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

607 {-# INLINE fmapMaybe #-}

661 {-# INLINE fmapMaybe #-}

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

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

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

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

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

634

688

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−

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

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

644-- supplied 'Event'.

690-- supplied 'Event'.

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

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

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

711

757

712{-# INLINE mergeWith' #-}

758{-# INLINE mergeWith' #-}

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

759mergeWith' :: 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)

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

715− . merge

761+ . mergeInt

716− . DMap.fromDistinctAscList

762+ . IntMap.fromDistinctAscList

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

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

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

719

764

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

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

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

880

925

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

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

882-- 'Event'.

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

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

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

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

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

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

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

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

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

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

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

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

898

949

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+

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

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

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

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

1021+{-# INLINE mapAccum_ #-}

901mapAccum_ :: 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)

1022mapAccum_ :: 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)

902mapAccum_ f z e = do

1023mapAccum_ f z e = do

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

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

904 return result

1025 return result

905

1026

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

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

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

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

1029+{-# INLINE mapAccumMaybe_ #-}

908mapAccumMaybe_ :: 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)

1030mapAccumMaybe_ :: 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)

909mapAccumMaybe_ f z e = do

1031mapAccumMaybe_ f z e = do

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

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

911 return result

1033 return result

912

1034

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

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

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

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

1037+{-# INLINE mapAccumM_ #-}

915mapAccumM_ :: 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)

1038mapAccumM_ :: 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)

916mapAccumM_ f z e = do

1039mapAccumM_ f z e = do

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

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

918 return result

1041 return result

919

1042

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

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

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

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

922-- 'Accumulator'.

1045-- 'Accumulator'.

1046+{-# INLINE mapAccumMaybeM_ #-}

923mapAccumMaybeM_ :: 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)

1047mapAccumMaybeM_ :: 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)

924mapAccumMaybeM_ f z e = do

1048mapAccumMaybeM_ f z e = do

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

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

926 return result

1050 return result

927

1051

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

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

929− accumMaybeM f z e = do

1053+ accumMaybeM = accumMaybeMDyn

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

1054+ mapAccumMaybeM = mapAccumMaybeMDyn

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

944

1055

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

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

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

1057+ accumMaybeM = accumMaybeMB

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

1058+ mapAccumMaybeM = mapAccumMaybeMB

948

1059

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

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

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

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

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

961 mapAccumMaybe_ f' l e

1072 mapAccumMaybe_ f' l e

962

1073

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

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

1075+{-# INLINE numberOccurrences #-}

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

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

965numberOccurrences = numberOccurrencesFrom 0

1077numberOccurrences = numberOccurrencesFrom 0

966

1078

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

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

1080+{-# INLINE numberOccurrencesFrom #-}

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

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

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

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

970

1083

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+

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

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

972--

1090--

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

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

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

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

975--

1093--

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

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

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

978--

1096--

979-- If we have:

1097-- If we have:

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

993--

1111--

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

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

995--

1113--

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

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

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

998--

1116--

999-- A more suggestive example might be:

1117-- A more suggestive example might be:

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

1010--

1128--

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

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

1012--

1130--

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

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

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

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

1015-- style syntax.

1133-- style syntax.

1016--

1134--

1017-- If we have:

1135-- If we have:

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

1022-- > e :: Event t c

1140-- > e :: Event t c

1023--

1141--

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

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

1025−--

1143+--

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

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

1027--

1145--

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

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

1029--

1147--

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,

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

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

1032--

1150--

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

1151-- 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.

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

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

1036(<@) = tag

1154(<@) = tag

1037infixl 4 <@

1155infixl 4 <@

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

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

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

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

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

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

1164 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'))

1047 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'))

1166 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'))

1048 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'))

1167 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'))

1049

1168

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

1051 runWithReplace a0 a' = do

1170 runWithReplace a0 a' = do

1052 r <- ask

1171 r <- ask

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

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

1054 traverseDMapWithKeyWithAdjust f dm0 dm' = do

1176 traverseDMapWithKeyWithAdjust f dm0 dm' = do

1055 r <- ask

1177 r <- ask

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

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

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

1108{-# INLINE mergeWithFoldCheap' #-}

1230{-# INLINE mergeWithFoldCheap' #-}

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

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

1110mergeWithFoldCheap' f es =

1232mergeWithFoldCheap' f es =

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

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

1112− . merge

1234+ . mergeInt

1113− . DMap.fromDistinctAscList

1235+ . IntMap.fromDistinctAscList

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

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

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

1116

1237

1117--------------------------------------------------------------------------------

1238--------------------------------------------------------------------------------

src/Reflex/Dynamic.hs+4−4

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

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

144-- of the 'Event'.

145foldDyn :: (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

147

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

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

150foldDynM :: (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

152

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

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

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

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

158-- in the 'Nothing' case.

159foldDynMaybe :: (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

161

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

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

164foldDynMaybeM :: (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

166

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

168count :: (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 }

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

33uniqDynamic :: 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

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

36 return $ unsafeJustChanged old new

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

81 let f' old change = do

82 mNew <- f old change

83 return $ unsafeJustChanged old =<< mNew

84− d <- accumMaybeM f' z e

84+ d <- accumMaybeMDyn f' z e

85 return $ UniqDynamic d

86 mapAccumMaybeM f z e = do

87 let f' old change = do

88 (mNew, output) <- f old change

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

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

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

91 return (UniqDynamic d, out)

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

src/Reflex/DynamicWriter.hs+2−1

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

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

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

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

9{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

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

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

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

34import Control.Monad.Reader

35import Control.Monad.Reader

35import Control.Monad.Ref

36import Control.Monad.Ref

36import Control.Monad.State.Strict

37import Control.Monad.State.Strict

37−import Data.Dependent.Map (DMap)

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

38import qualified Data.Dependent.Map as DMap

39import qualified Data.Dependent.Map as DMap

40+import Data.FastMutableIntMap

39import Data.Foldable

41import Data.Foldable

40import Data.Functor.Compose

42import Data.Functor.Compose

41import Data.Functor.Misc

43import 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

42import Data.List.NonEmpty (NonEmpty (..))

47import Data.List.NonEmpty (NonEmpty (..))

43import Data.Map (Map)

48import Data.Map (Map)

44import Data.Semigroup

49import Data.Semigroup

45−import Data.Sequence

46import Data.Some (Some)

50import Data.Some (Some)

47import Data.Tuple

51import Data.Tuple

52+import Data.Type.Equality

53+

54+import Unsafe.Coerce

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

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

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

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

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

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

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

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

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+

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

99-- | 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 }

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

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

102

58-- | Run a 'EventWriterT' action.

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

60runEventWriterT (EventWriterT a) = do

105runEventWriterT (EventWriterT a) = do

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

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

62− return (result, mconcat $ toList requests)

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

112

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

113instance (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+ }

120

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

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

68 tellEvent = lift . tellEvent

122 tellEvent = lift . tellEvent

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

74 sample = lift . sample

128 sample = lift . sample

129

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

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

131+ {-# INLINABLE hold #-}

77 hold v0 = lift . hold v0

132 hold v0 = lift . hold v0

133+ {-# INLINABLE holdDyn #-}

78 holdDyn v0 = lift . holdDyn v0

134 holdDyn v0 = lift . holdDyn v0

135+ {-# INLINABLE holdIncremental #-}

79 holdIncremental v0 = lift . holdIncremental v0

136 holdIncremental v0 = lift . holdIncremental v0

137+ {-# INLINABLE buildDynamic #-}

138+ buildDynamic a0 = lift . buildDynamic a0

139+ {-# INLINABLE headE #-}

140+ headE = lift . headE

141

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

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

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

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

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

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

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

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

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

147

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

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

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

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

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

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

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

151+ requesting = lift . requesting

90−

152+ requesting_ = lift . requesting_

153

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

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

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

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

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

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

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

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

101runWithReplaceEventWriterTWith f a0 a' = do

163runWithReplaceEventWriterTWith 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'

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

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

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

106 -- 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.)

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

167+ tellEvent $ coincidence $ updated request

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

168+ tellEvent $ switch $ current request

109 return (fst result0, fmapCheap fst result')

169 return (fst result0, fmapCheap fst result')

110

170

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+

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

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

112sequenceDMapWithAdjustEventWriterTWith :: 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))

203sequenceDMapWithAdjustEventWriterTWith :: 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))

114 -> DMap k v

205 -> DMap k v

115 -> Event t (p k v)

206 -> 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')))

117 )

208 )

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

209+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (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))

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

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

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

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

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

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

213 -> (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

124 -> Event t (p k v)

215 -> Event t (p k v)

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

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

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

217sequenceDMapWithAdjustEventWriterTWith 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)

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

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

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

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

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

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

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

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

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

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

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

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

224+ requests0 = weakenDMapWith (fst . getCompose) children0

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

225 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

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

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

137 -- 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.)

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

229+ tellEvent $ 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

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

140 [] -> Nothing

231 [] -> Nothing

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

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

142 return (result0, result')

233 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

31plugin = defaultPlugin { installCoreToDos = install }

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

34+install [] p = do

35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p

36+ let f = \case

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

38+ x -> [x]

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

39+ return $ makeInlinable : concatMap f p

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

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

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

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

37 install [] p

42 install [] p

src/Reflex/Patch.hs+1−1

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

10import Reflex.Patch.DMap as X

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

12import 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)

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

src/Reflex/Patch/Map.hs+4

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

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

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

19+ {-# INLINABLE apply #-}

19 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?

20 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?

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

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

21 deletions = Map.mapMaybeWithKey (const nothingToJust) p

22 deletions = Map.mapMaybeWithKey (const nothingToJust) p

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

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

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

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

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

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

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

64patchMapWithMoveNewElements :: 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

66 where f ni = case _nodeInfo_from ni of

69 where f ni = case _nodeInfo_from ni of

67 From_Insert v -> Just v

70 From_Insert v -> Just v

68 From_Move _ -> Nothing

71 From_Move _ -> Nothing

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

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

40import Data.Dependent.Map (DMap)

41import qualified Data.Dependent.Map as DMap

42import Data.Dependent.Sum

43+import Data.FastMutableIntMap

44+import Data.IntMap.Strict (IntMap)

45+import qualified Data.IntMap.Strict as IntMap

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

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

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

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

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

76 result0 <- lift a0

79 result0 <- lift a0

77 result' <- requestingIdentity a'

80 result' <- requestingIdentity a'

78 return (result0, result')

81 return (result0, result')

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

79− traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental (\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')

80− traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove (\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')

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

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

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

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

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

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

91 return (result0, result')

95 return (result0, result')

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+

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

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

94 {-# INLINABLE newEventWithTrigger #-}

109 {-# INLINABLE newEventWithTrigger #-}

95 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

110 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

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

123 case mToPerform of

138 case mToPerform of

124 Nothing -> return [result']

139 Nothing -> return [result']

125 Just toPerform -> do

140 Just toPerform -> do

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

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

127 mrt <- readRef responseTrigger

142 mrt <- readRef responseTrigger

128 let followupEventTriggers = case mrt of

143 let followupEventTriggers = case mrt of

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

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

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

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

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

145 {-# INLINABLE buildDynamic #-}

160 {-# INLINABLE buildDynamic #-}

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

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

162+ {-# INLINABLE headE #-}

163+ headE = PerformEventT . lift . headE

147

164

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

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

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

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

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

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

17module Reflex.PostBuild.Base

18 ( PostBuildT (..)

19 , runPostBuildT

20+ -- * Internal

21+ , mapIntMapWithAdjustImpl

22+ , mapDMapWithAdjustImpl

20 ) where

23 ) where

22import Reflex.Class

25import Reflex.Class

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

30import Control.Monad.Primitive

33import Control.Monad.Primitive

31import Control.Monad.Reader

34import Control.Monad.Reader

32import Control.Monad.Ref

35import Control.Monad.Ref

33−import Control.Monad.Trans.Control

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

34import Data.Dependent.Map (DMap)

37import Data.Dependent.Map (DMap)

35import qualified Data.Dependent.Map as DMap

38import qualified Data.Dependent.Map as DMap

36import Data.Functor.Compose

39import Data.Functor.Compose

40+import Data.IntMap.Strict (IntMap)

41+import qualified Data.IntMap.Strict as IntMap

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

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

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

44newtype 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

49 type PrimState (PostBuildT x m) = PrimState m

54 type PrimState (PostBuildT x m) = PrimState m

50 primitive = lift . primitive

55 primitive = lift . primitive

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−

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

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

60 {-# INLINABLE getPostBuild #-}

58 {-# INLINABLE getPostBuild #-}

61 getPostBuild = PostBuildT ask

59 getPostBuild = PostBuildT ask

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

71 holdDyn v0 = lift . holdDyn v0

69 holdDyn v0 = lift . holdDyn v0

72 {-# INLINABLE holdIncremental #-}

70 {-# INLINABLE holdIncremental #-}

73 holdIncremental v0 = lift . holdIncremental v0

71 holdIncremental v0 = lift . holdIncremental v0

72+ {-# INLINABLE buildDynamic #-}

73+ buildDynamic a0 = lift . buildDynamic a0

74+ {-# INLINABLE headE #-}

75+ headE = lift . headE

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

77instance 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

77 {-# INLINABLE performEvent_ #-}

79 {-# INLINABLE performEvent_ #-}

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

80+ performEvent_ = lift . performEvent_

79 {-# INLINABLE performEvent #-}

81 {-# INLINABLE performEvent #-}

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

82+ performEvent = lift . performEvent

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

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

83 {-# INLINABLE newEventWithTrigger #-}

85 {-# INLINABLE newEventWithTrigger #-}

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

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

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

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

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

114 return result

116 return result

117+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

118+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust

119+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

115 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

120 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

116 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

121 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

117

122

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

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

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

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

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

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

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

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

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

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

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

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

142 return (result0, result')

174 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

19import Reflex.Class

21import Control.Monad.Reader

22+import Control.Monad.State

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

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

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

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

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

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

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

34 getPostBuild = lift getPostBuild

36 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

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

35import qualified Data.Dependent.Map as DMap

36import Data.Functor.Identity

37+import Data.IntMap (IntMap)

38+import qualified Data.IntMap as IntMap

37import Data.Maybe

39import Data.Maybe

38import Data.MemoTrie

40import Data.MemoTrie

39import Data.Monoid

41import Data.Monoid

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

125 eventCoercion Coercion = Coercion

127 eventCoercion Coercion = Coercion

126 dynamicCoercion Coercion = Coercion

128 dynamicCoercion Coercion = Coercion

127

129

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

131+

132+ mergeIntIncremental = mergeIntIncrementalImpl

133+

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

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

129mergeIncrementalImpl i = Event $ \t ->

135mergeIncrementalImpl i = Event $ \t ->

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

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

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

132 then Nothing

138 then Nothing

133 else Just results

139 else Just results

134

140

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+

135instance Functor (Dynamic (Pure t)) where

148instance Functor (Dynamic (Pure t)) where

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

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

137 in (f cur, fmap f upd)

150 in (f cur, fmap f upd)

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

189 in case unEvent e lastTime of

202 in case unEvent e lastTime of

190 Nothing -> lastValue

203 Nothing -> lastValue

191 Just x -> fromMaybe lastValue $ apply x lastValue

204 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

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

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

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

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

271+ requesting = lift . requesting

272+ requesting_ = lift . requesting_

272

273

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

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

274 tellEvent = lift . tellEvent

275 tellEvent = lift . tellEvent

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

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

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

2-- 'Requester'.

3+{-# LANGUAGE AllowAmbiguousTypes #-}

3{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

6+{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE GADTs #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE Rank2Types #-}

12{-# LANGUAGE Rank2Types #-}

13+{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14#ifdef USE_REFLEX_OPTIMIZER

19#ifdef USE_REFLEX_OPTIMIZER

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

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

16#endif

21#endif

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

18 ( RequesterT (..)

23 ( RequesterT (..)

19 , runRequesterT

24 , runRequesterT

20 , runWithReplaceRequesterTWith

25 , runWithReplaceRequesterTWith

21− , sequenceDMapWithAdjustRequesterTWith

26+ , traverseIntMapWithKeyWithAdjustRequesterTWith

27+ , traverseDMapWithKeyWithAdjustRequesterTWith

28+ , RequesterData

29+ , RequesterDataKey

30+ , traverseRequesterData

31+ , requesterDataToList

32+ , singletonRequesterData

22 ) where

33 ) where

24import Reflex.Class

35import Reflex.Class

25−import Reflex.EventWriter

36+import Reflex.Dynamic

26import Reflex.Host.Class

37import Reflex.Host.Class

27import Reflex.PerformEvent.Class

38import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

39import Reflex.PostBuild.Class

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

32import Control.Monad.Exception

43import Control.Monad.Exception

33import Control.Monad.Identity

44import Control.Monad.Identity

34−import Control.Monad.Primitive

35import Control.Monad.Reader

45import Control.Monad.Reader

36import Control.Monad.Ref

46import Control.Monad.Ref

37import Control.Monad.State.Strict

47import Control.Monad.State.Strict

48+import Data.Bits

38import Data.Coerce

49import Data.Coerce

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

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

40import qualified Data.Dependent.Map as DMap

51import qualified Data.Dependent.Map as DMap

52+import qualified Data.Some as Some

53+import Data.FastMutableIntMap

54+import Data.Functor.Compose

41import Data.Functor.Misc

55import Data.Functor.Misc

56+import Data.IntMap.Strict (IntMap)

57+import qualified Data.IntMap.Strict as IntMap

42import Data.Map (Map)

58import Data.Map (Map)

59+import qualified Data.Map as Map

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

43import Data.Unique.Tag

61import Data.Unique.Tag

44import Data.Some (Some)

62import 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+ }

226

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

227-- | 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 }

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

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

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

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

50#if MIN_VERSION_base(4,9,1)

231#if MIN_VERSION_base(4,9,1)

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

245

65runRequesterT :: (Reflex t, Monad m)

246runRequesterT :: (Reflex t, Monad m)

66 => RequesterT t request response m a

247 => RequesterT t request response m a

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

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

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

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

69runRequesterT (RequesterT a) responses = do

250runRequesterT (RequesterT a) responses = do

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

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

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

252+ coerceEvent responses

72− return (result, requests)

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

254

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

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

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

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

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

77− withRequesting a = do

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

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

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

79− s <- RequesterT ask

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

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

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

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

82− return result

278

84instance MonadTrans (RequesterT t request response) where

279instance MonadTrans (RequesterT t request response) where

85 lift = RequesterT . lift . lift

280 lift = RequesterT . lift . lift

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

101

296

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

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

103 ask = lift ask

298 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

105 reader = lift . reader

300 reader = lift . reader

106

301

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

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

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

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

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

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

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

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

111

311

312+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

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

314+ , MonadFix m

315+ )

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

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

114 -> RequesterT t request response m a

317 -> RequesterT t request response m a

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

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

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

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

117−runWithReplaceRequesterTWith f a0 a' =

320+runWithReplaceRequesterTWith f a0 a' = do

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

321+ rec na' <- numberOccurrencesFrom 1 a'

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

322+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

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

323+ let responses' = fanInt responses

121− f' x y = do

324+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

122− r <- EventWriterT $ ask

325+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

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

326+ return (result0, fmapCheap (fst . snd) v')

124− in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

327+

125−

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

126−sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

374+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

127 ( GCompare k

375 ( GCompare k

128 , Reflex t

376 , Reflex t

129 , MonadHold t m

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

378+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

131− , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))

379+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

380+ , MonadFix m

132 )

381 )

133 => (forall k' v1 v2. GCompare k'

382 => (forall k' v1 v2. GCompare k'

134 => (forall a. k' a -> v1 a -> m (v2 a))

383 => (forall a. k' a -> v1 a -> m (v2 a))

@@ -136,21 +385,35 @@ sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

136 -> Event t (p k' v1)

385 -> Event t (p k' v1)

137 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

386 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

138 )

387 )

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)

140 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

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

142 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

391 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

143 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

392 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

144 -> DMap k v

393 -> DMap k v

145 -> Event t (p k v)

394 -> Event t (p k v)

146 -> RequesterT t request response m (DMap k v', Event t (p k v'))

395 -> RequesterT t request response m (DMap k v', Event t (p k v'))

147−sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =

396+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

148− let base' :: forall v1 v2.

397+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

149− (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))

398+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

150− -> DMap k v1

399+ responses = fanMap $ fmapCheap unpack response

151− -> Event t (p k v1)

400+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

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

401+ unpack = unEntry

153− base' f' x y = do

402+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

154− r <- EventWriterT ask

403+ pack = Entry

155− unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y

404+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

156− in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')

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

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FunctionalDependencies #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

12#ifdef USE_REFLEX_OPTIMIZER

13#ifdef USE_REFLEX_OPTIMIZER

@@ -14,8 +15,7 @@

14#endif

15#endif

15module Reflex.Requester.Class

16module Reflex.Requester.Class

16 ( Requester (..)

17 ( Requester (..)

17− , requesting

18+ , withRequesting

18− , requesting_

19 , requestingIdentity

20 ) where

@@ -36,52 +36,38 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

36 type Request m :: * -> *

37 -- | The type of responses that this 'Requester' can receive

38 type Response m :: * -> *

39− -- | Usually, end-user code should use 'requesting', 'requesting_', or

39+ -- | Emit a request whenever the given 'Event' fires, and return responses in

40− -- 'requestingIdentity'. For implementers of 'Requester', this function

40+ -- the resulting 'Event'.

41− -- provides a convenient way to define instances of the typeclass that

41+ requesting :: Event t (Request m a) -> m (Event t (Response m a))

42− -- efficiently support the underlying operations without needing to use

42+ -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

43− -- 'Control.Monad.Fix.MonadFix'.

43+ requesting_ :: Event t (Request m a) -> m ()

44− withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

44+

46instance Requester t m => Requester t (ReaderT r m) where

47 type Request (ReaderT r m) = Request m

48 type Response (ReaderT r m) = Response m

49− withRequesting f = do

49+ requesting = lift . requesting

50− r <- ask

50+ requesting_ = lift . requesting_

51− lift $ withRequesting $ (`runReaderT` r) . f

53instance Requester t m => Requester t (StateT s m) where

52instance Requester t m => Requester t (StateT s m) where

54 type Request (StateT s m) = Request m

53 type Request (StateT s m) = Request m

55 type Response (StateT s m) = Response m

54 type Response (StateT s m) = Response m

56− withRequesting f = do

55+ requesting = lift . requesting

57− old <- get

56+ requesting_ = lift . requesting_

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

64instance Requester t m => Requester t (Lazy.StateT s m) where

58instance Requester t m => Requester t (Lazy.StateT s m) where

65 type Request (Lazy.StateT s m) = Request m

59 type Request (Lazy.StateT s m) = Request m

66 type Response (Lazy.StateT s m) = Response m

60 type Response (Lazy.StateT s m) = Response m

67− withRequesting f = do

61+ requesting = lift . requesting

68− old <- Lazy.get

62+ requesting_ = lift . requesting_

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

84-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

64-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

85-- before returning them. @Response m@ must be 'Identity'.

65-- before returning them. @Response m@ must be 'Identity'.

86requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

66requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

87requestingIdentity = fmap coerceEvent . requesting

67requestingIdentity = 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 @@

8{-# LANGUAGE FunctionalDependencies #-}

9{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11−#if defined(DEBUG) || defined(DEBUG_CYCLES)

12{-# LANGUAGE LambdaCase #-}

11{-# LANGUAGE LambdaCase #-}

13−#endif

14{-# LANGUAGE MagicHash #-}

12{-# LANGUAGE MagicHash #-}

15{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE MultiParamTypeClasses #-}

16{-# LANGUAGE MultiWayIf #-}

14{-# LANGUAGE MultiWayIf #-}

@@ -59,9 +57,12 @@ import Data.Proxy

59import Data.These

57import Data.These

60import Data.Traversable

58import Data.Traversable

61import Data.Word

59import Data.Word

60+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

61+import qualified Data.FastMutableIntMap as FastMutableIntMap

62import GHC.Exts

63import GHC.IORef (IORef (..))

64import GHC.Stack

65+import Reflex.FastWeak

65import Reflex.FunctorMaybe

66import Reflex.FunctorMaybe

66import System.IO.Unsafe

67import System.IO.Unsafe

67import System.Mem.Weak

68import System.Mem.Weak

@@ -75,6 +76,8 @@ import Data.Monoid (mempty)

75import Data.Tree (Forest, Tree (..), drawForest)

76import Data.Tree (Forest, Tree (..), drawForest)

76#endif

77#endif

79+import Data.FastWeakBag (FastWeakBag)

80+import qualified Data.FastWeakBag as FastWeakBag

78import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

81import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

79import qualified Data.WeakBag as WeakBag

82import qualified Data.WeakBag as WeakBag

80#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

83#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -240,22 +243,57 @@ subscribeAndRead = unEvent

240-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

243-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

241-- caching; if the computation function is very cheap, this is (much) more

244-- caching; if the computation function is very cheap, this is (much) more

242-- efficient than 'push'

245-- efficient than 'push'

243−{-# NOINLINE pushCheap #-}

246+{-# INLINE [1] pushCheap #-}

244pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

247pushCheap :: 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

246 (subscription, occ) <- subscribeAndRead e $ sub

249 (subscription, occ) <- subscribeAndRead e $ sub

247 { subscriberPropagate = \a -> do

250 { subscriberPropagate = \a -> do

248− mb <- runComputeM $ f a

251+ mb <- f a

249 mapM_ (subscriberPropagate sub) mb

252 mapM_ (subscriberPropagate sub) mb

250 }

253 }

251− occ' <- join <$> mapM (runComputeM . f) occ

254+ occ' <- join <$> mapM f occ

252 return (subscription, occ')

255 return (subscription, occ')

253

256

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+

254data CacheSubscribed x a

294data CacheSubscribed x a

255− = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))

295+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

256− , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))

257 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

296 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

258− , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))

259 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

297 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

260 }

298 }

261

299

@@ -263,62 +301,67 @@ data CacheSubscribed x a

263-- repeatedly

301-- repeatedly

264--

302--

265--TODO: Try a caching strategy where we subscribe directly to the parent when

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

267--subscriber joins

305--subscriber joins

268−{-# NOINLINE cacheEvent #-}

306+{-# NOINLINE [0] cacheEvent #-}

269−cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

307+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

270cacheEvent e =

308cacheEvent e =

271#ifdef DEBUG_TRACE_EVENTS

309#ifdef DEBUG_TRACE_EVENTS

272 withStackOneLine $ \callSite -> Event $

310 withStackOneLine $ \callSite -> Event $

273#else

311#else

274 Event $

312 Event $

275#endif

313#endif

314+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

276− let !mSubscribedRef = unsafeNewIORef e Nothing

315+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak

277 in \sub -> {-# SCC "cacheEvent" #-} do

316 in \sub -> {-# SCC "cacheEvent" #-} do

278#ifdef DEBUG_TRACE_EVENTS

317#ifdef DEBUG_TRACE_EVENTS

279 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

318 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

280#endif

319#endif

281− mSubscribed <- liftIO $ readIORef mSubscribedRef

320+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

282− case mSubscribed of

321+ Just subscribedTicket -> return subscribedTicket

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)

291 Nothing -> do

322 Nothing -> do

292− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

323+ subscribers <- liftIO FastWeakBag.empty

293− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

294− occRef <- liftIO $ newIORef undefined

324+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

295 (parentSub, occ) <- subscribeAndRead e $ Subscriber

325 (parentSub, occ) <- subscribeAndRead e $ Subscriber

296 { subscriberPropagate = \a -> do

326 { subscriberPropagate = \a -> do

297 liftIO $ writeIORef occRef $ Just a

327 liftIO $ writeIORef occRef $ Just a

298 scheduleClear occRef

328 scheduleClear occRef

299− propagate a subscribers

329+ propagateFast a subscribers

300 , subscriberInvalidateHeight = \old -> do

330 , subscriberInvalidateHeight = \old -> do

301− WeakBag.traverse subscribers $ invalidateSubscriberHeight old

331+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

302 , subscriberRecalculateHeight = \new -> do

332 , subscriberRecalculateHeight = \new -> do

303− WeakBag.traverse subscribers $ recalculateSubscriberHeight new

333+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

304 }

334 }

305− liftIO $ writeIORef occRef occ

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

306− when (isJust occ) $ scheduleClear occRef

337+ scheduleClear occRef

307 let !subscribed = CacheSubscribed

338 let !subscribed = CacheSubscribed

308 { _cacheSubscribed_subscribers = subscribers

339 { _cacheSubscribed_subscribers = subscribers

309− , _cacheSubscribed_weakSelf = weakSelf

310 , _cacheSubscribed_parent = parentSub

340 , _cacheSubscribed_parent = parentSub

311− , _cacheSubscribed_cached = mSubscribedRef

312 , _cacheSubscribed_occurrence = occRef

341 , _cacheSubscribed_occurrence = occRef

313 }

342 }

343+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

314− liftIO $ writeIORef mSubscribedRef $ Just subscribed

344+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

315− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

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

316− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

360+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

317−

361+ , eventSubscribedRetained = toAny subscribedTicket

318−cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

362+ }

319−cleanupCacheSubscribed self = do

363+ }

320− unsubscribe $ _cacheSubscribed_parent self

364+ return (es, occ)

321− writeIORef (_cacheSubscribed_cached self) Nothing

322

365

323subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

366subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

324subscribe e s = fst <$> subscribeAndRead e s

367subscribe e s = fst <$> subscribeAndRead e s

@@ -352,7 +395,7 @@ eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

352eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

395eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

353

396

354{-# INLINE subscribeCoincidenceInner #-}

397{-# 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)

356subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

399subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

357 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

400 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

358 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

401 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

@@ -497,6 +540,13 @@ propagate a subscribers = withIncreasedDepth $ do

497 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

540 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

498 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

541 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

499

542

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+

500--------------------------------------------------------------------------------

550--------------------------------------------------------------------------------

501-- EventSubscribed

551-- EventSubscribed

502--------------------------------------------------------------------------------

552--------------------------------------------------------------------------------

@@ -595,7 +645,7 @@ walkInvalidHeightParents s0 = do

595#endif

645#endif

596

646

597{-# INLINE subscribeHoldEvent #-}

647{-# 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)

599subscribeHoldEvent = subscribeAndRead . holdEvent

649subscribeHoldEvent = subscribeAndRead . holdEvent

600

650

601--------------------------------------------------------------------------------

651--------------------------------------------------------------------------------

@@ -751,6 +801,7 @@ data EventEnv x

751 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

801 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

752 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

802 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

753 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

803 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

804+ , eventEnvIntClears :: !(IORef [SomeIntClear])

754 , eventEnvRootClears :: !(IORef [SomeRootClear])

805 , eventEnvRootClears :: !(IORef [SomeRootClear])

755 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

806 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

756 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

807 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

@@ -835,6 +886,14 @@ instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

835scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

886scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

836scheduleClear r = defer $ SomeClear r

887scheduleClear r = defer $ SomeClear r

837

888

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+

838instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

897instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

839 {-# INLINE getDeferralQueue #-}

898 {-# INLINE getDeferralQueue #-}

840 getDeferralQueue = asksEventEnv eventEnvRootClears

899 getDeferralQueue = asksEventEnv eventEnvRootClears

@@ -870,7 +929,7 @@ hold v0 e = do

870 return h

929 return h

871

930

872{-# INLINE getHoldEventSubscription #-}

931{-# 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)

874getHoldEventSubscription h = do

933getHoldEventSubscription h = do

875 ep <- liftIO $ readIORef $ holdParent h

934 ep <- liftIO $ readIORef $ holdParent h

876 case ep of

935 case ep of

@@ -970,21 +1029,6 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

970-- EventM can do everything BehaviorM can, plus create holds

1029-- EventM can do everything BehaviorM can, plus create holds

971newtype 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

1030newtype 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

972

1031

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−

988newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1032newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

989

1033

990data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove

1034data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove

@@ -1111,7 +1155,7 @@ instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1111

1155

1112instance HasSpiderTimeline x => Align (Event x) where

1156instance HasSpiderTimeline x => Align (Event x) where

1113 nil = eventNever

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

1115

1159

1116newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1160newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1117

1161

@@ -1230,9 +1274,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1230 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1274 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1231 EQ -> a

1275 EQ -> a

1232

1276

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

1234

1280

1235−data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1281+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))

1236

1282

1237data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1283data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1238

1284

@@ -1363,16 +1409,6 @@ getDynHold d = do

1363zeroRef :: IORef Height

1409zeroRef :: IORef Height

1364zeroRef = unsafePerformIO $ newIORef zeroHeight

1410zeroRef = unsafePerformIO $ newIORef zeroHeight

1365

1411

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−

1376getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1412getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1377getRootSubscribed k r sub = do

1413getRootSubscribed k r sub = do

1378 mSubscribed <- readIORef $ rootSubscribed r

1414 mSubscribed <- readIORef $ rootSubscribed r

@@ -1428,8 +1464,71 @@ cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribe

1428subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1464subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1429subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1465subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1430

1466

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+

1431{-# INLINABLE getFanSubscribed #-}

1530{-# 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)

1433getFanSubscribed k f sub = do

1532getFanSubscribed k f sub = do

1434 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1533 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1435 case mSubscribed of

1534 case mSubscribed of

@@ -1488,7 +1587,7 @@ subscribeFanSubscribed k subscribed sub = do

1488 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1587 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1489

1588

1490{-# INLINABLE getSwitchSubscribed #-}

1589{-# 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)

1492getSwitchSubscribed s sub = do

1591getSwitchSubscribed s sub = do

1493 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1592 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1494 case mSubscribed of

1593 case mSubscribed of

@@ -1544,7 +1643,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBa

1544subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1643subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1545

1644

1546{-# INLINABLE getCoincidenceSubscribed #-}

1645{-# 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)

1548getCoincidenceSubscribed c sub = do

1647getCoincidenceSubscribed c sub = do

1549 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1648 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1550 case mSubscribed of

1649 case mSubscribed of

@@ -1607,7 +1706,7 @@ mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1607

1706

1608{-# INLINE [1] mergeCheap #-}

1707{-# INLINE [1] mergeCheap #-}

1609mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1708mergeCheap :: 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

1611 where

1710 where

1612 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1711 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1613 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1712 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1642,7 +1741,7 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1642

1741

1643{-# INLINE [1] mergeCheapWithMove #-}

1742{-# INLINE [1] mergeCheapWithMove #-}

1644mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1743mergeCheapWithMove :: 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

1646 where

1745 where

1647 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1746 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1648 updateMe subscriber heightBagRef oldParents p = do

1747 updateMe subscriber heightBagRef oldParents p = do

@@ -1700,78 +1799,108 @@ type MergeDestroyFunc k s

1700 = DMap k s

1799 = DMap k s

1701 -> IO ()

1800 -> IO ()

1702

1801

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+

1703{-# INLINE mergeCheap' #-}

1888{-# 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)

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)

1705−mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do

1890+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1706 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1891 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1707 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1892 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1708 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1893 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1709 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1894 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1710 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1895 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1711− let scheduleSelf height = scheduleMerge' height heightRef $ do

1896+ let m = Merge

1712− m <- liftIO $ readIORef accumRef

1897+ { _merge_parentsRef = parentsRef

1713− liftIO $ writeIORef accumRef $! DMap.empty

1898+ , _merge_heightBagRef = heightBagRef

1714− --TODO: Assert that m is not empty

1899+ , _merge_heightRef = heightRef

1715− subscriberPropagate sub m

1900+ , _merge_sub = sub

1716− invalidateMyHeight = do

1901+ , _merge_accumRef = accumRef

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

1768 }

1902 }

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

1775 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1904 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1776 myHeight = if invalidHeight `elem` heights

1905 myHeight = if invalidHeight `elem` heights

1777 then invalidHeight

1906 then invalidHeight

@@ -1781,9 +1910,7 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1781 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1910 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1782 else (Nothing, dm)

1911 else (Nothing, dm)

1783 unless (DMap.null accum) $ do

1912 unless (DMap.null accum) $ do

1784− scheduleSelf myHeight

1913+ scheduleMergeSelf m myHeight

1785− occRef <- liftIO $ newIORef occ

1786− when (isJust occ) $ scheduleClear occRef

1787 liftIO $ writeIORef accumRef $! accum

1914 liftIO $ writeIORef accumRef $! accum

1788 liftIO $ writeIORef heightRef $! myHeight

1915 liftIO $ writeIORef heightRef $! myHeight

1789 liftIO $ writeIORef heightBagRef $! myHeightBag

1916 liftIO $ writeIORef heightBagRef $! myHeightBag

@@ -1793,12 +1920,12 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1793 let s = Subscriber

1920 let s = Subscriber

1794 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1921 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1795 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1922 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1796− defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1923+ defer $ updateMerge m updateFunc a

1797 , subscriberInvalidateHeight = \_ -> return ()

1924 , subscriberInvalidateHeight = \_ -> return ()

1798 , subscriberRecalculateHeight = \_ -> return ()

1925 , subscriberRecalculateHeight = \_ -> return ()

1799 }

1926 }

1800 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1927 (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

1802 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1929 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1803 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1930 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1804 -- its subscription.

1931 -- its subscription.

@@ -1808,6 +1935,106 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1808 , occ

1935 , occ

1809 )

1936 )

1810

1937

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+

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

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

1812

2039

1813fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2040fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

@@ -1847,13 +2074,14 @@ newEventEnv = do

1847 mergeInitRef <- newIORef []

2074 mergeInitRef <- newIORef []

1848 heightRef <- newIORef zeroHeight

2075 heightRef <- newIORef zeroHeight

1849 toClearRef <- newIORef []

2076 toClearRef <- newIORef []

2077+ toClearIntRef <- newIORef []

1850 toClearRootRef <- newIORef []

2078 toClearRootRef <- newIORef []

1851 coincidenceInfosRef <- newIORef []

2079 coincidenceInfosRef <- newIORef []

1852 delayedRef <- newIORef IntMap.empty

2080 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

1854

2082

1855clearEventEnv :: EventEnv x -> IO ()

2083clearEventEnv :: 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

1857 writeIORef toAssignRef []

2085 writeIORef toAssignRef []

1858 writeIORef holdInitRef []

2086 writeIORef holdInitRef []

1859 writeIORef dynInitRef []

2087 writeIORef dynInitRef []

@@ -1861,6 +2089,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

1861 writeIORef mergeInitRef []

2089 writeIORef mergeInitRef []

1862 writeIORef heightRef zeroHeight

2090 writeIORef heightRef zeroHeight

1863 writeIORef toClearRef []

2091 writeIORef toClearRef []

2092+ writeIORef toClearIntRef []

1864 writeIORef toClearRootRef []

2093 writeIORef toClearRootRef []

1865 writeIORef coincidenceInfosRef []

2094 writeIORef coincidenceInfosRef []

1866 writeIORef delayedRef IntMap.empty

2095 writeIORef delayedRef IntMap.empty

@@ -1876,6 +2105,8 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

1876 result <- runEventM go

2105 result <- runEventM go

1877 toClear <- readIORef $ eventEnvClears env

2106 toClear <- readIORef $ eventEnvClears env

1878 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

2107 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

1879 toClearRoot <- readIORef $ eventEnvRootClears env

2110 toClearRoot <- readIORef $ eventEnvRootClears env

1880 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2111 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1881 toAssign <- readIORef $ eventEnvAssignments env

2112 toAssign <- readIORef $ eventEnvAssignments env

@@ -2070,6 +2301,8 @@ withSpiderTimeline k = do

2070

2301

2071newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2302newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2072

2303

2304+type ComputeM = EventM

2305+

2073newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2306newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2074

2307

2075#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2308#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -2122,6 +2355,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2122 eventCoercion Coercion = Coercion

2355 eventCoercion Coercion = Coercion

2123 behaviorCoercion Coercion = Coercion

2356 behaviorCoercion Coercion = Coercion

2124 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

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

2125#endif

2362#endif

2126

2363

2127data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2364data 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

18 holdIncremental = holdIncrementalSpiderEventM

19 {-# INLINABLE buildDynamic #-}

20 buildDynamic = buildDynamicSpiderEventM

21+ {-# INLINABLE headE #-}

22+ headE = R.slowHeadE

23+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

22instance (

25instance (

23#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

26#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -30,6 +33,8 @@ instance (

30instance (

33instance (

31#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

34#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32 x ~ Global

35 x ~ Global

36+#else

37+ HasSpiderTimeline x

33#endif

38#endif

34 ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

39 ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

35 {-# INLINABLE sample #-}

40 {-# INLINABLE sample #-}

@@ -44,6 +49,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

44 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

49 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

45 {-# INLINABLE buildDynamic #-}

50 {-# INLINABLE buildDynamic #-}

46 buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

51 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

48instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

56instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

49 {-# INLINE return #-}

57 {-# INLINE return #-}

@@ -55,6 +63,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

55 {-# INLINE fail #-}

63 {-# INLINE fail #-}

56 fail _ = error "Dynamic does not support 'fail'"

64 fail _ = error "Dynamic does not support 'fail'"

66+{-# INLINABLE newJoinDyn #-}

58newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

67newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

59newJoinDyn d =

68newJoinDyn d =

60 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

69 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

@@ -66,12 +75,16 @@ newJoinDyn d =

67instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

76instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

68 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

77 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

78+ x <$ _ = pure x

70instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

80instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

71 pure = SpiderDynamic . dynamicConst

81 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

72 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

85 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

73 _ *> b = b

86 _ *> b = b

74− a <* _ = a

87+ a <* _ = a --TODO: The semantics of *>, <*, and <$ might not be quite right - they drop changes

76holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

89holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

77holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

90holdSpiderEventM 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

94 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

107 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

95 {-# INLINABLE buildDynamic #-}

108 {-# INLINABLE buildDynamic #-}

96 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

109 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

110+ {-# INLINABLE headE #-}

111+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

112

98instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

113instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

99 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

114 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

107 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

122 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

108 {-# INLINABLE buildDynamic #-}

123 {-# INLINABLE buildDynamic #-}

109 buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

124 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

110

128

111instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

129instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

112 {-# INLINABLE sample #-}

130 {-# INLINABLE sample #-}

@@ -125,6 +143,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

125 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

143 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

126 {-# INLINABLE buildDynamic #-}

144 {-# INLINABLE buildDynamic #-}

127 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

145 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

128

148

129--------------------------------------------------------------------------------

149--------------------------------------------------------------------------------

130-- Deprecated items

150-- Deprecated items

src/Reflex/TriggerEvent/Base.hs+6

@@ -114,10 +114,16 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

114 holdDyn v0 v' = lift $ holdDyn v0 v'

115 {-# INLINABLE holdIncremental #-}

116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117+ {-# INLINABLE buildDynamic #-}

118+ buildDynamic a0 = lift . buildDynamic a0

119+ {-# INLINABLE headE #-}

120+ headE = lift . headE

117

121

118instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

122instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

119 {-# INLINABLE runWithReplace #-}

123 {-# INLINABLE runWithReplace #-}

120 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

124 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

125+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

126+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

121 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

127 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

122 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

128 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

123 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

129 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

src/Reflex/TriggerEvent/Class.hs+12

@@ -11,6 +11,8 @@ module Reflex.TriggerEvent.Class

11import Reflex.Class

13import Control.Monad.Reader

14+import Control.Monad.State

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

15--TODO: Shouldn't have IO hard-coded

17--TODO: Shouldn't have IO hard-coded

16-- | 'TriggerEvent' represents actions that can create 'Event's that can be

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

36 newTriggerEvent = lift newTriggerEvent

38 newTriggerEvent = lift newTriggerEvent

37 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

39 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

38 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

40 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

40 holdDyn initial = liftPlan . holdDyn initial

41 holdIncremental initial = liftPlan . holdIncremental initial

42 buildDynamic getInitial = liftPlan . buildDynamic getInitial

43+ headE = liftPlan . headE

44instance MonadSample (Pure Int) PurePlan where

45instance MonadSample (Pure Int) PurePlan where

45 sample = liftPlan . sample

46 sample = liftPlan . sample