git.iko.soy/reflex
on develop help sign in
Merge branch 'develop' into cleanup-debug
6cbfdf8Oliver Batchelor
CONTRIBUTING.md+9
compare with develop
unifiedsplit
@@ -5,6 +5,7 @@ Contributions and issue reports are encouraged and appreciated!
5- [Opening Issues](#opening-issues)
5- [Opening Issues](#opening-issues)
6- [Submitting Changes](#submitting-changes)
6- [Submitting Changes](#submitting-changes)
7 - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
7 - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
8+ - [Guidelines for Pull Requests](#guidelines-for-pull-requests)
8 - [Code Quality](#code-quality)
9 - [Code Quality](#code-quality)
9 - [Documentation](#documentation)
10 - [Documentation](#documentation)
10
11
@@ -30,6 +31,10 @@ One way to think about it is that your commit message should be able to complete
30#### Body
31#### Body
31For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.
32For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.
32
33
34+### Guidelines for Pull Requests
35+
36+Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.
37+
33### Code Quality
38### Code Quality
34
39
35#### Warnings
40#### Warnings
@@ -40,6 +45,10 @@ Your pull request should add no new warnings to the project. It should also gene
40
45
41Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!
46Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!
42
47
48+#### Dependencies
49+
50+Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to reflex.cabal also need to be added to default.nix.
51+
43### Documentation
52### Documentation
44
53
45#### In the code
54#### In the code
ChangeLog.md+14
@@ -1,7 +1,21 @@
1# Revision history for reflex
1# Revision history for reflex
2
2
3+## 0.6.2.1
4+
5+* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`
6+ values.
7+
8+* Generalize merging functions:
9+ `merge` to `mergeG`,
10+ `mergeIncremental` to `mergeIncrementalG`,
11+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
12+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
13+
14+
3## 0.6.2.0
15## 0.6.2.0
4
16
17+* Fix `holdDyn` so that it is lazy in its event argument
18+ These produce `DMap`s whose values needn't be `Identity`.
5* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
19* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
6* Fix `holdDyn` so that it is lazy in its event argument.
20* Fix `holdDyn` so that it is lazy in its event argument.
7
21
default.nix+1−1
@@ -11,7 +11,7 @@
11}:
11}:
12mkDerivation {
12mkDerivation {
13 pname = "reflex";
13 pname = "reflex";
14− version = "0.6.2.0";
14+ version = "0.6.2.1";
15 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
15 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
16 libraryHaskellDepends = [
16 libraryHaskellDepends = [
17 base bifunctors containers dependent-map dependent-sum
17 base bifunctors containers dependent-map dependent-sum
reflex.cabal+5−2
@@ -1,5 +1,5 @@
1Name: reflex
1Name: reflex
2−Version: 0.6.2.0
2+Version: 0.6.2.1
3Synopsis: Higher-order Functional Reactive Programming
3Synopsis: Higher-order Functional Reactive Programming
4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
5License: BSD3
5License: BSD3
@@ -55,12 +55,14 @@ library
55 data-default >= 0.5 && < 0.8,
55 data-default >= 0.5 && < 0.8,
56 dependent-map >= 0.3 && < 0.4,
56 dependent-map >= 0.3 && < 0.4,
57 exception-transformers == 0.4.*,
57 exception-transformers == 0.4.*,
58+ profunctors,
58 lens >= 4.7 && < 5,
59 lens >= 4.7 && < 5,
59 monad-control >= 1.0.1 && < 1.1,
60 monad-control >= 1.0.1 && < 1.1,
60− monoidal-containers == 0.4.*,
61+ monoidal-containers >= 0.4 && < 0.6,
61 mtl >= 2.1 && < 2.3,
62 mtl >= 2.1 && < 2.3,
62 prim-uniq >= 0.1.0.1 && < 0.2,
63 prim-uniq >= 0.1.0.1 && < 0.2,
63 primitive >= 0.5 && < 0.7,
64 primitive >= 0.5 && < 0.7,
65+ profunctors,
64 random == 1.1.*,
66 random == 1.1.*,
65 ref-tf == 0.4.*,
67 ref-tf == 0.4.*,
66 reflection == 2.1.*,
68 reflection == 2.1.*,
@@ -76,6 +78,7 @@ library
76 witherable >= 0.2 && < 0.4
78 witherable >= 0.2 && < 0.4
77
79
78 exposed-modules:
80 exposed-modules:
81+ Control.Monad.ReaderIO
79 Data.AppendMap,
82 Data.AppendMap,
80 Data.FastMutableIntMap,
83 Data.FastMutableIntMap,
81 Data.FastWeakBag,
84 Data.FastWeakBag,
src/Control/Monad/ReaderIO.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# language RoleAnnotations #-}
2+{-# language MultiParamTypeClasses #-}
3+{-# language FlexibleInstances #-}
4+{-# language CPP #-}
5+module Control.Monad.ReaderIO
6+ (
7+ ReaderIO (..)
8+ )
9+ where
10+
11+import Control.Monad.Fix
12+#if MIN_VERSION_base(4,10,0)
13+import Control.Applicative
14+#endif
15+import Control.Monad
16+import Control.Monad.Reader.Class
17+import Control.Monad.IO.Class
18+
19+-- | An approximate clone of @RIO@ from the @rio@ package, but not based on
20+-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a
21+-- @nominal@ role, so we can't coerce through it when it's wrapped in some
22+-- other @data@ type. Ugh.
23+newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }
24+type role ReaderIO representational representational
25+
26+instance Functor (ReaderIO e) where
27+ fmap = liftM
28+ {-# INLINE fmap #-}
29+ a <$ m = m >> pure a
30+ {-# INLINE (<$) #-}
31+
32+instance Applicative (ReaderIO e) where
33+ pure a = ReaderIO $ \_ -> pure a
34+ {-# INLINE pure #-}
35+ (<*>) = ap
36+ {-# INLINE (<*>) #-}
37+#if MIN_VERSION_base(4,10,0)
38+ liftA2 = liftM2
39+ {-# INLINE liftA2 #-}
40+#endif
41+ (*>) = (>>)
42+ {-# INLINE (*>) #-}
43+
44+instance Monad (ReaderIO e) where
45+ ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e
46+ {-# INLINE (>>=) #-}
47+
48+instance MonadFix (ReaderIO e) where
49+ mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e
50+ {-# INLINE mfix #-}
51+
52+instance MonadIO (ReaderIO e) where
53+ liftIO m = ReaderIO $ \_ -> m
54+ {-# INLINE liftIO #-}
55+
56+instance MonadReader e (ReaderIO e) where
57+ ask = ReaderIO pure
58+ {-# INLINE ask #-}
59+ local f (ReaderIO m) = ReaderIO (m . f)
60+ {-# INLINE local #-}
src/Reflex/Class.hs+86−9
@@ -17,6 +17,7 @@
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE Trustworthy #-}
20#ifdef USE_REFLEX_OPTIMIZER
21#ifdef USE_REFLEX_OPTIMIZER
21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22#endif
23#endif
@@ -36,16 +37,21 @@ module Reflex.Class
36 , coerceBehavior
37 , coerceBehavior
37 , coerceEvent
38 , coerceEvent
38 , coerceDynamic
39 , coerceDynamic
40+ , coerceIncremental
39 , MonadSample (..)
41 , MonadSample (..)
40 , MonadHold (..)
42 , MonadHold (..)
41 -- ** 'fan' related types
43 -- ** 'fan' related types
42 , EventSelector (..)
44 , EventSelector (..)
45+ , EventSelectorG (..)
43 , EventSelectorInt (..)
46 , EventSelectorInt (..)
44 -- * Convenience functions
47 -- * Convenience functions
45 , constDyn
48 , constDyn
46 , pushAlways
49 , pushAlways
47 -- ** Combining 'Event's
50 -- ** Combining 'Event's
48 , leftmost
51 , leftmost
52+ , merge
53+ , mergeIncremental
54+ , mergeIncrementalWithMove
49 , mergeMap
55 , mergeMap
50 , mergeIntMap
56 , mergeIntMap
51 , mergeMapIncremental
57 , mergeMapIncremental
@@ -60,6 +66,7 @@ module Reflex.Class
60 , alignEventWithMaybe
66 , alignEventWithMaybe
61 -- ** Breaking up 'Event's
67 -- ** Breaking up 'Event's
62 , splitE
68 , splitE
69+ , fan
63 , fanEither
70 , fanEither
64 , fanThese
71 , fanThese
65 , fanMap
72 , fanMap
@@ -84,6 +91,7 @@ module Reflex.Class
84 , gate
91 , gate
85 -- ** Combining 'Dynamic's
92 -- ** Combining 'Dynamic's
86 , distributeDMapOverDynPure
93 , distributeDMapOverDynPure
94+ , distributeDMapOverDynPureG
87 , distributeListOverDyn
95 , distributeListOverDyn
88 , distributeListOverDynWith
96 , distributeListOverDynWith
89 , zipDyn
97 , zipDyn
@@ -255,11 +263,16 @@ class ( MonadHold t (PushM t)
255 -- | Merge a collection of events; the resulting 'Event' will only occur if at
263 -- | Merge a collection of events; the resulting 'Event' will only occur if at
256 -- least one input event is occurring, and will contain all of the input keys
264 -- least one input event is occurring, and will contain all of the input keys
257 -- that are occurring simultaneously
265 -- that are occurring simultaneously
266+
258− merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
267+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
268+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))
269+ -> DMap k q -> Event t (DMap k v)
270+
259 -- | Efficiently fan-out an event to many destinations. You should save the
271 -- | Efficiently fan-out an event to many destinations. You should save the
260− -- result in a @let@-binding, and then repeatedly 'select' on the result to
272+ -- result in a @let@-binding, and then repeatedly 'selectG' on the result to
261 -- create child events
273 -- create child events
262− fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k
274+ fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v
275+
263 -- | Create an 'Event' that will occur whenever the currently-selected input
276 -- | Create an 'Event' that will occur whenever the currently-selected input
264 -- 'Event' occurs
277 -- 'Event' occurs
265 switch :: Behavior t (Event t a) -> Event t a
278 switch :: Behavior t (Event t a) -> Event t a
@@ -277,9 +290,14 @@ class ( MonadHold t (PushM t)
277 -- that value.
290 -- that value.
278 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
291 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
279 -- | Create a merge whose parents can change over time
292 -- | Create a merge whose parents can change over time
293+ mergeIncrementalG :: GCompare k
294+ => (forall a. q a -> Event t (v a))
280− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
295+ -> Incremental t (PatchDMap k q)
296+ -> Event t (DMap k v)
281 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
297 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
298+ mergeIncrementalWithMoveG :: GCompare k
299+ => (forall a. q a -> Event t (v a))
282− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
300+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
283 -- | Extract the 'Behavior' component of an 'Incremental'
301 -- | Extract the 'Behavior' component of an 'Incremental'
284 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
302 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
285 -- | Extract the 'Event' component of an 'Incremental'
303 -- | Extract the 'Event' component of an 'Incremental'
@@ -295,9 +313,25 @@ class ( MonadHold t (PushM t)
295 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
313 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
296 -- occurrence type
314 -- occurrence type
297 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
315 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
316+ -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its
317+ -- patch target and patch types.
318+ incrementalCoercion
319+ :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)
298 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
320 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
299 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
321 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
300
322
323+-- | Efficiently fan-out an event to many destinations. You should save the
324+-- result in a @let@-binding, and then repeatedly 'select' on the result to
325+-- create child events
326+fan :: forall t k. (Reflex t, GCompare k)
327+ => Event t (DMap k Identity) -> EventSelector t k
328+ --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
329+fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)
330+ where
331+ fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a
332+ fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of
333+ Coercion -> coerce
334+
301--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
335--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
302-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
336-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
303-- keys simultaneously.
337-- keys simultaneously.
@@ -316,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion
316coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
350coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
317coerceDynamic = coerceWith $ dynamicCoercion Coercion
351coerceDynamic = coerceWith $ dynamicCoercion Coercion
318
352
353+-- | Coerce an 'Incremental' between representationally-equivalent value types
354+coerceIncremental
355+ :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))
356+ => Incremental t a -> Incremental t b
357+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion
358+
319-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
359-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
320-- __must__ change when and only when the 'Event' fires, such that the
360-- __must__ change when and only when the 'Event' fires, such that the
321-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
361-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
@@ -485,6 +525,17 @@ newtype EventSelector t k = EventSelector
485 select :: forall a. k a -> Event t a
525 select :: forall a. k a -> Event t a
486 }
526 }
487
527
528+newtype EventSelectorG t k v = EventSelectorG
529+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
530+ -- determined by the type of the key, so this can be used to fan-out
531+ -- 'Event's whose sub-'Event's have different types.
532+ --
533+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
534+ -- (but equivalent to) using 'mapMaybe' to select only the relevant
535+ -- occurrences of an 'Event'.
536+ selectG :: forall a. k a -> Event t (v a)
537+ }
538+
488-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
539-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
489-- filtering by key.
540-- filtering by key.
490newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
541newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
@@ -1079,12 +1130,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1079-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1130-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1080-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1131-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1081distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1132distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1082−distributeDMapOverDynPure dm = case DMap.toList dm of
1133+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic
1134+
1135+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1136+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1137+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1138+distributeDMapOverDynPureG
1139+ :: forall t k q v. (Reflex t, GCompare k)
1140+ => (forall a. q a -> Dynamic t (v a))
1141+ -> DMap k q -> Dynamic t (DMap k v)
1142+distributeDMapOverDynPureG nt dm = case DMap.toList dm of
1083 [] -> constDyn DMap.empty
1143 [] -> constDyn DMap.empty
1084− [k :=> v] -> fmap (DMap.singleton k . Identity) v
1144+ [k :=> v] -> DMap.singleton k <$> nt v
1085 _ ->
1145 _ ->
1086− let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1146+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1087− edmPre = merge $ DMap.map updated dm
1147+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
1088 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1148 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1089 olds <- sample $ current result
1149 olds <- sample $ current result
1090 return $ DMap.unionWithKey (\_ _ new -> new) olds news
1150 return $ DMap.unionWithKey (\_ _ new -> new) olds news
@@ -1557,6 +1617,23 @@ fmapCheap f = pushCheap $ return . Just . f
1557tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1617tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1558tagCheap b = pushAlwaysCheap $ \_ -> sample b
1618tagCheap b = pushAlwaysCheap $ \_ -> sample b
1559
1619
1620+-- | Merge a collection of events; the resulting 'Event' will only occur if at
1621+-- least one input event is occurring, and will contain all of the input keys
1622+-- that are occurring simultaneously
1623+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
1624+merge = mergeG coerceEvent
1625+{-# INLINE merge #-}
1626+
1627+-- | Create a merge whose parents can change over time
1628+mergeIncremental :: (Reflex t, GCompare k)
1629+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
1630+mergeIncremental = mergeIncrementalG coerceEvent
1631+
1632+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
1633+mergeIncrementalWithMove :: (Reflex t, GCompare k)
1634+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
1635+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent
1636+
1560-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
1637-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
1561{-# INLINE mergeWithCheap #-}
1638{-# INLINE mergeWithCheap #-}
1562mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1639mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
src/Reflex/Profiled.hs+21−13
@@ -8,6 +8,9 @@
8{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE RankNTypes #-}
11-- |
14-- |
12-- Module:
15-- Module:
13-- Reflex.Profiled
16-- Reflex.Profiled
@@ -16,7 +19,6 @@
16-- profiling/cost-center information.
19-- profiling/cost-center information.
17module Reflex.Profiled where
20module Reflex.Profiled where
18
21
19−import Control.Lens hiding (children)
20import Control.Monad
22import Control.Monad
21import Control.Monad.Exception
23import Control.Monad.Exception
22import Control.Monad.Fix
24import Control.Monad.Fix
@@ -33,6 +35,7 @@ import Data.Map (Map)
33import qualified Data.Map.Strict as Map
35import qualified Data.Map.Strict as Map
34import Data.Monoid ((<>))
36import Data.Monoid ((<>))
35import Data.Ord
37import Data.Ord
38+import Data.Profunctor.Unsafe ((#.))
36import qualified Data.Semigroup as S
39import qualified Data.Semigroup as S
37import Data.Type.Coercion
40import Data.Type.Coercion
38import Foreign.Ptr
41import Foreign.Ptr
@@ -133,27 +136,32 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
134 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
135 pull = Behavior_Profiled . pull . coerce
138 pull = Behavior_Profiled . pull . coerce
136− merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
139+ fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
140+ mergeG :: forall (k :: z -> *) q v. GCompare k
141+ => (forall a. q a -> Event (ProfiledTimeline t) (v a))
137− merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
142+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
138− fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
143+ mergeG nt = Event_Profiled #. mergeG (coerce nt)
139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
141 current (Dynamic_Profiled d) = coerce $ current d
146 current (Dynamic_Profiled d) = coerce $ current d
142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
147 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
148 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
144 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
149 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
145− mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
150+ mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
146− mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
151+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
150− behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
155+ behaviorCoercion c =
151− Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
156+ Coercion `trans` behaviorCoercion @t c `trans` Coercion
152− eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
157+ eventCoercion c =
153− Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
158+ Coercion `trans` eventCoercion @t c `trans` Coercion
159+ dynamicCoercion c =
154− dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
160+ Coercion `trans` dynamicCoercion @t c `trans` Coercion
155− Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
161+ incrementalCoercion c d =
162+ Coercion `trans` incrementalCoercion @t c d `trans` Coercion
156− mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
163+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .
164+ coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
157 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
165 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
158
166
159deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
167deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
src/Reflex/Pure.hs+20−12
@@ -5,6 +5,9 @@
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE PolyKinds #-}
10+
8#ifdef USE_REFLEX_OPTIMIZER
11#ifdef USE_REFLEX_OPTIMIZER
9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10#endif
13#endif
@@ -43,10 +46,11 @@ import Data.MemoTrie
43import Data.Monoid
46import Data.Monoid
44import Data.Type.Coercion
47import Data.Type.Coercion
45import Reflex.Class
48import Reflex.Class
49+import Data.Kind (Type)
46
50
47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
51-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
48-- with the type @/t/@.
52-- with the type @/t/@.
49−data Pure t
53+data Pure (t :: Type)
50
54
51-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
55-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
52-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
56-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
@@ -79,17 +83,18 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
79 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
83 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
80 -- warning because the GCompare instance is not used; however, removing the
84 -- warning because the GCompare instance is not used; however, removing the
81 -- GCompare instance produces a different warning, due to that constraint
85 -- GCompare instance produces a different warning, due to that constraint
82− -- being present in the original class definition
86+ -- being present in the original class definition.
83
87
84− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
88+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
89+ -- -> DMap k q -> Event (Pure t) (DMap k v)
85− merge events = Event $ memo $ \t ->
90+ mergeG nt events = Event $ memo $ \t ->
86− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
91+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
87 in if DMap.null currentOccurrences
92 in if DMap.null currentOccurrences
88 then Nothing
93 then Nothing
89 else Just currentOccurrences
94 else Just currentOccurrences
90
95
91− fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
96+ -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
92− fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
97+ fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
93
98
94 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
99 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
95 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
100 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
@@ -112,8 +117,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
112 --a) -> Incremental (Pure t) p a
117 --a) -> Incremental (Pure t) p a
113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
118 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
114
119
115− mergeIncremental = mergeIncrementalImpl
120+ mergeIncrementalG = mergeIncrementalImpl
116− mergeIncrementalWithMove = mergeIncrementalImpl
121+ mergeIncrementalWithMoveG = mergeIncrementalImpl
117
122
118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
123 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
119
124
@@ -128,14 +133,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
128 behaviorCoercion Coercion = Coercion
133 behaviorCoercion Coercion = Coercion
129 eventCoercion Coercion = Coercion
134 eventCoercion Coercion = Coercion
130 dynamicCoercion Coercion = Coercion
135 dynamicCoercion Coercion = Coercion
136+ incrementalCoercion Coercion Coercion = Coercion
131
137
132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
138 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
133
139
134 mergeIntIncremental = mergeIntIncrementalImpl
140 mergeIntIncremental = mergeIntIncrementalImpl
135
141
136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
142+mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
143+ => (forall a. q a -> Event (Pure t) (v a))
144+ -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
137−mergeIncrementalImpl i = Event $ \t ->
145+mergeIncrementalImpl nt i = Event $ \t ->
138− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
146+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
139 in if DMap.null results
147 in if DMap.null results
140 then Nothing
148 then Nothing
141 else Just results
149 else Just results
src/Reflex/Spider/Internal.hs+214−162
@@ -17,9 +17,15 @@
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE DeriveFunctor #-}
22+{-# LANGUAGE StandaloneDeriving #-}
23+{-# LANGUAGE InstanceSigs #-}
24+
20#ifdef USE_REFLEX_OPTIMIZER
25#ifdef USE_REFLEX_OPTIMIZER
21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
26{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22#endif
27#endif
28+{-# OPTIONS_GHC -Wunused-binds #-}
23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
29-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
30-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
31module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -33,7 +39,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
33import Control.Monad.Exception
39import Control.Monad.Exception
34import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
35import Control.Monad.Primitive
41import Control.Monad.Primitive
36−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
43+import Control.Monad.Reader.Class
44+import Control.Monad.IO.Class
45+import Control.Monad.ReaderIO
37import Control.Monad.Ref
46import Control.Monad.Ref
38import Data.Align
47import Data.Align
39import Data.Coerce
48import Data.Coerce
@@ -49,6 +58,7 @@ import Data.GADT.Compare
49import Data.IntMap.Strict (IntMap)
58import Data.IntMap.Strict (IntMap)
50import qualified Data.IntMap.Strict as IntMap
59import qualified Data.IntMap.Strict as IntMap
51import Data.IORef
60import Data.IORef
61+import Data.Kind (Type)
52import Data.Maybe hiding (mapMaybe)
62import Data.Maybe hiding (mapMaybe)
53import Data.Monoid ((<>))
63import Data.Monoid ((<>))
54import Data.Proxy
64import Data.Proxy
@@ -76,6 +86,7 @@ import qualified Data.FastWeakBag as FastWeakBag
76import Data.Reflection
86import Data.Reflection
77import Data.Some (Some(Some))
87import Data.Some (Some(Some))
78import Data.Type.Coercion
88import Data.Type.Coercion
89+import Data.Profunctor.Unsafe ((#.), (.#))
79import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
90import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
80import qualified Data.WeakBag as WeakBag
91import qualified Data.WeakBag as WeakBag
81import qualified Reflex.Class
92import qualified Reflex.Class
@@ -144,12 +155,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
144
155
145newNodeId :: IO Int
156newNodeId :: IO Int
146newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
157newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
147−
148−{-# NOINLINE unsafeNodeId #-}
149−unsafeNodeId :: a -> Int
150−unsafeNodeId a = unsafePerformIO $ do
151− touch a
152− newNodeId
153#endif
158#endif
154
159
155--------------------------------------------------------------------------------
160--------------------------------------------------------------------------------
@@ -253,9 +258,10 @@ cacheEvent e =
253#else
258#else
254 Event $
259 Event $
255#endif
260#endif
261+ unsafePerformIO $ do
256− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
262+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
257− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
263+ <- newIORef emptyFastWeak
258− in \sub -> {-# SCC "cacheEvent" #-} do
264+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
259#ifdef DEBUG_TRACE_EVENTS
265#ifdef DEBUG_TRACE_EVENTS
260 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
266 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
261#endif
267#endif
@@ -321,7 +327,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
321eventNever :: Event x a
327eventNever :: Event x a
322eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
328eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
323
329
324−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
330+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
325eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
331eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
326
332
327eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
333eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -373,14 +379,14 @@ newSubscriberHold h = return $ Subscriber
373 , subscriberRecalculateHeight = \_ -> return ()
379 , subscriberRecalculateHeight = \_ -> return ()
374 }
380 }
375
381
376−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
382+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
377newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
383newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
378 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
384 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
379 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
385 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
380 tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
386 tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
381 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
387 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
382 scheduleClear $ fanSubscribedOccurrence subscribed
388 scheduleClear $ fanSubscribedOccurrence subscribed
383− let f _ (Pair (Identity v) subsubs) = do
389+ let f _ (Pair v subsubs) = do
384 propagate v $ _fanSubscribedChildren_list subsubs
390 propagate v $ _fanSubscribedChildren_list subsubs
385 return $ Constant ()
391 return $ Constant ()
386 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
392 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -475,6 +481,11 @@ propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
475toAny :: a -> Any
481toAny :: a -> Any
476toAny = unsafeCoerce
482toAny = unsafeCoerce
477
483
484+-- Why do we use Any here, instead of just giving eventSubscribedRetained an
485+-- existential type? Sadly, GHC does not currently know how to unbox types
486+-- with existentially quantified fields. So instead we just coerce values
487+-- to type Any on the way in. Since we never coerce them back, this is
488+-- perfectly safe.
478data EventSubscribed x = EventSubscribed
489data EventSubscribed x = EventSubscribed
479 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
490 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
480 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
491 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -507,7 +518,7 @@ eventSubscribedNever = EventSubscribed
507#endif
518#endif
508 }
519 }
509
520
510−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
521+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
511eventSubscribedFan !subscribed = EventSubscribed
522eventSubscribedFan !subscribed = EventSubscribed
512 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
523 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
513 , eventSubscribedRetained = toAny subscribed
524 , eventSubscribedRetained = toAny subscribed
@@ -598,7 +609,7 @@ behaviorPull !p = Behavior $ do
598 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
609 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
599 parentsRef <- liftIO $ newIORef []
610 parentsRef <- liftIO $ newIORef []
600 holdInits <- askBehaviorHoldInits
611 holdInits <- askBehaviorHoldInits
601− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
612+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
602 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
613 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
603 parents <- liftIO $ readIORef parentsRef
614 parents <- liftIO $ readIORef parentsRef
604 let subscribed = PullSubscribed
615 let subscribed = PullSubscribed
@@ -633,42 +644,46 @@ readBehaviorUntracked b = do
633-- Dynamic
644-- Dynamic
634--------------------------------------------------------------------------------
645--------------------------------------------------------------------------------
635
646
647+type DynamicS x p = Dynamic x (PatchTarget p) p
648+
636−data Dynamic x p = Dynamic
649+data Dynamic x target p = Dynamic
637− { dynamicCurrent :: !(Behavior x (PatchTarget p))
650+ { dynamicCurrent :: !(Behavior x target)
638 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
651 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
639 }
652 }
640
653
654+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
655+
656+
657+
658+
641−dynamicHold :: Hold x p -> Dynamic x p
659+dynamicHold :: Hold x p -> DynamicS x p
642dynamicHold !h = Dynamic
660dynamicHold !h = Dynamic
643 { dynamicCurrent = behaviorHold h
661 { dynamicCurrent = behaviorHold h
644 , dynamicUpdated = eventHold h
662 , dynamicUpdated = eventHold h
645 }
663 }
646
664
647−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
665+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
648dynamicHoldIdentity = dynamicHold
666dynamicHoldIdentity = dynamicHold
649
667
650−dynamicConst :: PatchTarget p -> Dynamic x p
668+dynamicConst :: PatchTarget p -> DynamicS x p
651dynamicConst !a = Dynamic
669dynamicConst !a = Dynamic
652 { dynamicCurrent = behaviorConst a
670 { dynamicCurrent = behaviorConst a
653 , dynamicUpdated = eventNever
671 , dynamicUpdated = eventNever
654 }
672 }
655
673
656−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
674+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
657dynamicDyn !d = Dynamic
675dynamicDyn !d = Dynamic
658 { dynamicCurrent = behaviorDyn d
676 { dynamicCurrent = behaviorDyn d
659 , dynamicUpdated = eventDyn d
677 , dynamicUpdated = eventDyn d
660 }
678 }
661
679
662−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
680+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
663dynamicDynIdentity = dynamicDyn
681dynamicDynIdentity = dynamicDyn
664
682
665--------------------------------------------------------------------------------
683--------------------------------------------------------------------------------
666-- Combinators
684-- Combinators
667--------------------------------------------------------------------------------
685--------------------------------------------------------------------------------
668
686
669−--TODO: Figure out why certain things are not 'representational', then make them
670−--representational so we can use coerce
671−
672--type role Hold representational
687--type role Hold representational
673data Hold x p
688data Hold x p
674 = Hold { holdValue :: !(IORef (PatchTarget p))
689 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -689,20 +704,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
689
704
690-- | Stores all global data relevant to a particular Spider timeline; only one
705-- | Stores all global data relevant to a particular Spider timeline; only one
691-- value should exist for each type @x@
706-- value should exist for each type @x@
707+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
708+-- We implement SpiderTimelineEnv with a newtype wrapper so
709+-- we can get the coercions we want safely.
710+type role SpiderTimelineEnv nominal
711+
692−data SpiderTimelineEnv x = SpiderTimelineEnv
712+data SpiderTimelineEnv' x = SpiderTimelineEnv
693 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
713 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
694 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
714 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
695#ifdef DEBUG
715#ifdef DEBUG
696 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
716 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
697#endif
717#endif
698 }
718 }
699−type role SpiderTimelineEnv nominal
719+type role SpiderTimelineEnv' phantom
700
720
701instance Eq (SpiderTimelineEnv x) where
721instance Eq (SpiderTimelineEnv x) where
702 _ == _ = True -- Since only one exists of each type
722 _ == _ = True -- Since only one exists of each type
703
723
704instance GEq SpiderTimelineEnv where
724instance GEq SpiderTimelineEnv where
705− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
725+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
706 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
726 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
707 else Nothing
727 else Nothing
708
728
@@ -725,7 +745,7 @@ runEventM :: EventM x a -> IO a
725runEventM = unEventM
745runEventM = unEventM
726
746
727asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
747asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
728−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
748+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
729
749
730class MonadIO m => Defer a m where
750class MonadIO m => Defer a m where
731 getDeferralQueue :: m (IORef [a])
751 getDeferralQueue :: m (IORef [a])
@@ -863,9 +883,9 @@ getHoldEventSubscription h = do
863
883
864type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
884type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
865
885
866−--type role BehaviorM representational
867-- BehaviorM can sample behaviors
886-- BehaviorM can sample behaviors
868−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
887+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
888+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
869
889
870instance Monad (BehaviorM x) where
890instance Monad (BehaviorM x) where
871 {-# INLINE (>>=) #-}
891 {-# INLINE (>>=) #-}
@@ -916,7 +936,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
916#endif
936#endif
917 }
937 }
918
938
919−data Root x (k :: * -> *)
939+data Root x k
920 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
940 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
921 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
941 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
922 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
942 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -986,25 +1006,25 @@ heightBagVerify b@(HeightBag s c) = if
986heightBagVerify = id
1006heightBagVerify = id
987#endif
1007#endif
988
1008
989−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1009+data FanSubscribedChildren x k v a = FanSubscribedChildren
990− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1010+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
991− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1011+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
992− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1012+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
993 }
1013 }
994
1014
995−data FanSubscribed (x :: *) k
1015+data FanSubscribed x k v
996− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1016+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
997− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1017+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
998− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1018+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
999 , fanSubscribedParent :: !(EventSubscription x)
1019 , fanSubscribedParent :: !(EventSubscription x)
1000#ifdef DEBUG_NODEIDS
1020#ifdef DEBUG_NODEIDS
1001 , fanSubscribedNodeId :: Int
1021 , fanSubscribedNodeId :: Int
1002#endif
1022#endif
1003 }
1023 }
1004
1024
1005−data Fan x k
1025+data Fan x k v
1006− = Fan { fanParent :: !(Event x (DMap k Identity))
1026+ = Fan { fanParent :: !(Event x (DMap k v))
1007− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1027+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1008 }
1028 }
1009
1029
1010data SwitchSubscribed x a
1030data SwitchSubscribed x a
@@ -1066,19 +1086,20 @@ instance HasSpiderTimeline x => Align (Event x) where
1066#if MIN_VERSION_these(0, 8, 0)
1086#if MIN_VERSION_these(0, 8, 0)
1067instance HasSpiderTimeline x => Semialign (Event x) where
1087instance HasSpiderTimeline x => Semialign (Event x) where
1068#endif
1088#endif
1089+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1069− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1090+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1070
1091
1071data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1092data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1072 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1093 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1073 | HoldDyn !(Hold x p)
1094 | HoldDyn !(Hold x p)
1074
1095
1075−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1096+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1076
1097
1077−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1098+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1078newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1099newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1079
1100
1080--TODO: Avoid the duplication between this and R.zipDynWith
1101--TODO: Avoid the duplication between this and R.zipDynWith
1081−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1102+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1082zipDynWith f da db =
1103zipDynWith f da db =
1083 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1104 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1084 ec = flip push eab $ \o -> do
1105 ec = flip push eab $ \o -> do
@@ -1101,18 +1122,12 @@ buildDynamic readV0 v' = do
1101 return d
1122 return d
1102
1123
1103unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1124unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1104−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1125+unsafeBuildDynamic readV0 v' =
1105− where x = (readV0, v')
1126+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1106
1127
1107-- ResultM can read behaviors and events
1128-- ResultM can read behaviors and events
1108type ResultM = EventM
1129type ResultM = EventM
1109
1130
1110−{-# NOINLINE unsafeNewIORef #-}
1111−unsafeNewIORef :: a -> b -> IORef b
1112−unsafeNewIORef a b = unsafePerformIO $ do
1113− touch a
1114− newIORef b
1115−
1116instance HasSpiderTimeline x => Functor (Event x) where
1131instance HasSpiderTimeline x => Functor (Event x) where
1117 fmap f = push $ return . Just . f
1132 fmap f = push $ return . Just . f
1118
1133
@@ -1125,33 +1140,42 @@ push f e = cacheEvent (pushCheap f e)
1125
1140
1126{-# INLINABLE pull #-}
1141{-# INLINABLE pull #-}
1127pull :: BehaviorM x a -> Behavior x a
1142pull :: BehaviorM x a -> Behavior x a
1128−pull a = behaviorPull $ Pull
1143+pull a = unsafePerformIO $ do
1129− { pullCompute = a
1144+ ref <- newIORef Nothing
1130− , pullValue = unsafeNewIORef a Nothing
1131#ifdef DEBUG_NODEIDS
1145#ifdef DEBUG_NODEIDS
1132− , pullNodeId = unsafeNodeId a
1146+ nid <- newNodeId
1133#endif
1147#endif
1148+ pure $ behaviorPull $ Pull
1149+ { pullCompute = a
1150+ , pullValue = ref
1151+#ifdef DEBUG_NODEIDS
1152+ , pullNodeId = nid
1153+#endif
1134− }
1154+ }
1135
1155
1136{-# INLINABLE switch #-}
1156{-# INLINABLE switch #-}
1137switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1157switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1158+switch a = unsafePerformIO $ do
1159+ ref <- newIORef Nothing
1138−switch a = eventSwitch $ Switch
1160+ pure $ eventSwitch $ Switch
1139− { switchParent = a
1161+ { switchParent = a
1140− , switchSubscribed = unsafeNewIORef a Nothing
1162+ , switchSubscribed = ref
1141− }
1163+ }
1142
1164
1143coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1165coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1166+coincidence a = unsafePerformIO $ do
1167+ ref <- newIORef Nothing
1144−coincidence a = eventCoincidence $ Coincidence
1168+ pure $ eventCoincidence $ Coincidence
1145− { coincidenceParent = a
1169+ { coincidenceParent = a
1146− , coincidenceSubscribed = unsafeNewIORef a Nothing
1170+ , coincidenceSubscribed = ref
1147− }
1171+ }
1148
1172
1149-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1173-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1150run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1174run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1151run roots after = do
1175run roots after = do
1152 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1176 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1153 let t = spiderTimeline :: SpiderTimelineEnv x
1177 let t = spiderTimeline :: SpiderTimelineEnv x
1154− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1178+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1155 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1179 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1156 occBefore <- liftIO $ do
1180 occBefore <- liftIO $ do
1157 occBefore <- readIORef occRef
1181 occBefore <- readIORef occRef
@@ -1237,9 +1261,9 @@ debugSubscriber description subscribed = return $ Subscriber
1237{-# INLINE withIncreasedDepth #-}
1261{-# INLINE withIncreasedDepth #-}
1238withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1262withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1239withIncreasedDepth _ a = do
1263withIncreasedDepth _ a = do
1240− liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) succ
1264+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ
1241 result <- a
1265 result <- a
1242− liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) pred
1266+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
1243 return result
1267 return result
1244
1268
1245{-# INLINE tracePropagate #-}
1269{-# INLINE tracePropagate #-}
@@ -1258,7 +1282,7 @@ trace p message = traceM p $ return message
1258traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1282traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1259traceM _ getMessage = do
1283traceM _ getMessage = do
1260 message <- getMessage
1284 message <- getMessage
1261− d <- liftIO $ readIORef $ _spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)
1285+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1262 liftIO $ putStrLn $ replicate d ' ' <> message
1286 liftIO $ putStrLn $ replicate d ' ' <> message
1263
1287
1264#else
1288#else
@@ -1329,25 +1353,25 @@ propagateSubscriberHold h a = do
1329data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1353data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1330
1354
1331runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1355runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1332−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1356+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1333
1357
1334askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1358askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1335askInvalidator = do
1359askInvalidator = do
1336− (!m, _) <- BehaviorM ask
1360+ (!m, _) <- ask
1337 case m of
1361 case m of
1338 Nothing -> return Nothing
1362 Nothing -> return Nothing
1339 Just (!wi, _) -> return $ Just wi
1363 Just (!wi, _) -> return $ Just wi
1340
1364
1341askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1365askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1342askParentsRef = do
1366askParentsRef = do
1343− (!m, _) <- BehaviorM ask
1367+ (!m, _) <- ask
1344 case m of
1368 case m of
1345 Nothing -> return Nothing
1369 Nothing -> return Nothing
1346 Just (_, !p) -> return $ Just p
1370 Just (_, !p) -> return $ Just p
1347
1371
1348askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1372askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1349askBehaviorHoldInits = do
1373askBehaviorHoldInits = do
1350− (_, !his) <- BehaviorM ask
1374+ (_, !his) <- ask
1351 return his
1375 return his
1352
1376
1353{-# INLINE getDynHold #-}
1377{-# INLINE getDynHold #-}
@@ -1394,6 +1418,9 @@ getRootSubscribed k r sub = do
1394
1418
1395 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1419 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1396 writeIORef uninitRef $! uninit
1420 writeIORef uninitRef $! uninit
1421+#ifdef DEBUG_NODEIDS
1422+ nid <- newNodeId
1423+#endif
1397 let !subscribed = RootSubscribed
1424 let !subscribed = RootSubscribed
1398 { rootSubscribedKey = k
1425 { rootSubscribedKey = k
1399 , rootSubscribedCachedSubscribed = cached
1426 , rootSubscribedCachedSubscribed = cached
@@ -1402,7 +1429,7 @@ getRootSubscribed k r sub = do
1402 , rootSubscribedUninit = uninit
1429 , rootSubscribedUninit = uninit
1403 , rootSubscribedWeakSelf = weakSelf
1430 , rootSubscribedWeakSelf = weakSelf
1404#ifdef DEBUG_NODEIDS
1431#ifdef DEBUG_NODEIDS
1405− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1432+ , rootSubscribedNodeId = nid
1406#endif
1433#endif
1407 }
1434 }
1408 -- If we die at the same moment that all our children die, they will
1435 -- If we die at the same moment that all our children die, they will
@@ -1451,16 +1478,10 @@ newFanInt = do
1451 , _fanInt_occRef = occRef
1478 , _fanInt_occRef = occRef
1452 }
1479 }
1453
1480
1454−{-# NOINLINE unsafeNewFanInt #-}
1455−unsafeNewFanInt :: b -> FanInt x a
1456−unsafeNewFanInt b = unsafePerformIO $ do
1457− touch b
1458− newFanInt
1459−
1460fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1481fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1461−fanInt p =
1482+fanInt p = unsafePerformIO $ do
1462− let self = unsafeNewFanInt p
1483+ self <- newFanInt
1463− in EventSelectorInt $ \k -> Event $ \sub -> do
1484+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1464 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1485 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1465 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1486 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1466 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1487 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1496,7 +1517,7 @@ fanInt p =
1496 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1517 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1497
1518
1498{-# INLINABLE getFanSubscribed #-}
1519{-# INLINABLE getFanSubscribed #-}
1499−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1520+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1500getFanSubscribed k f sub = do
1521getFanSubscribed k f sub = do
1501 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1522 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1502 case mSubscribed of
1523 case mSubscribed of
@@ -1514,13 +1535,16 @@ getFanSubscribed k f sub = do
1514 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1535 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1515 occRef <- liftIO $ newIORef parentOcc
1536 occRef <- liftIO $ newIORef parentOcc
1516 when (isJust parentOcc) $ scheduleClear occRef
1537 when (isJust parentOcc) $ scheduleClear occRef
1538+#ifdef DEBUG_NODEIDS
1539+ nid <- liftIO newNodeId
1540+#endif
1517 let subscribed = FanSubscribed
1541 let subscribed = FanSubscribed
1518 { fanSubscribedCachedSubscribed = fanSubscribed f
1542 { fanSubscribedCachedSubscribed = fanSubscribed f
1519 , fanSubscribedOccurrence = occRef
1543 , fanSubscribedOccurrence = occRef
1520 , fanSubscribedParent = subscription
1544 , fanSubscribedParent = subscription
1521 , fanSubscribedSubscribers = subscribersRef
1545 , fanSubscribedSubscribers = subscribersRef
1522#ifdef DEBUG_NODEIDS
1546#ifdef DEBUG_NODEIDS
1523− , fanSubscribedNodeId = unsafeNodeId f
1547+ , fanSubscribedNodeId = nid
1524#endif
1548#endif
1525 }
1549 }
1526 let !self = (k, subscribed)
1550 let !self = (k, subscribed)
@@ -1530,7 +1554,7 @@ getFanSubscribed k f sub = do
1530 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1554 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1531 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1555 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1532
1556
1533−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1557+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1534cleanupFanSubscribed (k, subscribed) = do
1558cleanupFanSubscribed (k, subscribed) = do
1535 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1559 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1536 let reducedSubscribers = DMap.delete k subscribers
1560 let reducedSubscribers = DMap.delete k subscribers
@@ -1542,7 +1566,7 @@ cleanupFanSubscribed (k, subscribed) = do
1542 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1566 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1543
1567
1544{-# INLINE subscribeFanSubscribed #-}
1568{-# INLINE subscribeFanSubscribed #-}
1545−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1569+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1546subscribeFanSubscribed k subscribed sub = do
1570subscribeFanSubscribed k subscribed sub = do
1547 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1571 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1548 case DMap.lookup k subscribers of
1572 case DMap.lookup k subscribers of
@@ -1580,6 +1604,9 @@ getSwitchSubscribed s sub = do
1580 when (isJust parentOcc) $ scheduleClear occRef
1604 when (isJust parentOcc) $ scheduleClear occRef
1581 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1605 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1582 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1606 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1607+#ifdef DEBUG_NODEIDS
1608+ nid <- liftIO newNodeId
1609+#endif
1583 let !subscribed = SwitchSubscribed
1610 let !subscribed = SwitchSubscribed
1584 { switchSubscribedCachedSubscribed = switchSubscribed s
1611 { switchSubscribedCachedSubscribed = switchSubscribed s
1585 , switchSubscribedOccurrence = occRef
1612 , switchSubscribedOccurrence = occRef
@@ -1592,7 +1619,7 @@ getSwitchSubscribed s sub = do
1592 , switchSubscribedCurrentParent = subscriptionRef
1619 , switchSubscribedCurrentParent = subscriptionRef
1593 , switchSubscribedWeakSelf = weakSelf
1620 , switchSubscribedWeakSelf = weakSelf
1594#ifdef DEBUG_NODEIDS
1621#ifdef DEBUG_NODEIDS
1595− , switchSubscribedNodeId = unsafeNodeId s
1622+ , switchSubscribedNodeId = nid
1596#endif
1623#endif
1597 }
1624 }
1598 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1625 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1637,6 +1664,9 @@ getCoincidenceSubscribed c sub = do
1637 scheduleClear innerSubdRef
1664 scheduleClear innerSubdRef
1638 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1665 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1639 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1666 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1667+#ifdef DEBUG_NODEIDS
1668+ nid <- liftIO newNodeId
1669+#endif
1640 let subscribed = CoincidenceSubscribed
1670 let subscribed = CoincidenceSubscribed
1641 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1671 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1642 , coincidenceSubscribedOccurrence = occRef
1672 , coincidenceSubscribedOccurrence = occRef
@@ -1647,7 +1677,7 @@ getCoincidenceSubscribed c sub = do
1647 , coincidenceSubscribedInnerParent = innerSubdRef
1677 , coincidenceSubscribedInnerParent = innerSubdRef
1648 , coincidenceSubscribedWeakSelf = weakSelf
1678 , coincidenceSubscribedWeakSelf = weakSelf
1649#ifdef DEBUG_NODEIDS
1679#ifdef DEBUG_NODEIDS
1650− , coincidenceSubscribedNodeId = unsafeNodeId c
1680+ , coincidenceSubscribedNodeId = nid
1651#endif
1681#endif
1652 }
1682 }
1653 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1683 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1664,26 +1694,34 @@ cleanupCoincidenceSubscribed subscribed = do
1664subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1694subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1665subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1695subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1666
1696
1667−{-# INLINE merge #-}
1697+{-# INLINE mergeG #-}
1668−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1698+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1699+ => (forall a. q a -> Event x (v a))
1700+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1669−merge d = cacheEvent (mergeCheap d)
1701+mergeG nt d = cacheEvent (mergeCheap nt d)
1670
1702
1671{-# INLINE mergeWithMove #-}
1703{-# INLINE mergeWithMove #-}
1672−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1704+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1705+ => (forall a. q a -> Event x (v a))
1706+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1673−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1707+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1674
1708
1675{-# INLINE [1] mergeCheap #-}
1709{-# INLINE [1] mergeCheap #-}
1710+mergeCheap
1676−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1711+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1712+ => (forall a. q a -> Event x (v a))
1713+ -> DynamicS x (PatchDMap k q)
1714+ -> Event x (DMap k v)
1677−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1715+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1678 where
1716 where
1679− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1717+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1680 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1718 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1681 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1719 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1682 (mOldSubd, newPs) <- case me of
1720 (mOldSubd, newPs) <- case me of
1683 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1721 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1684 Just e -> do
1722 Just e -> do
1685 let s = subscriber $ return k
1723 let s = subscriber $ return k
1686− subscription@(EventSubscription _ subd) <- subscribe e s
1724+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1687 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1725 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1688 let newParent = MergeSubscribedParent subscription
1726 let newParent = MergeSubscribedParent subscription
1689 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1727 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1693,28 +1731,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1693 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1731 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1694 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1732 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1695 foldM f ([], oldParents) $ DMap.toList p
1733 foldM f ([], oldParents) $ DMap.toList p
1734+
1696− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1735+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1697 getInitialSubscribers initialParents subscriber = do
1736 getInitialSubscribers initialParents subscriber = do
1698 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1737 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1699 let s = subscriber $ return k
1738 let s = subscriber $ return k
1700− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1739+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1701 height <- liftIO $ getEventSubscribedHeight parentSubd
1740 height <- liftIO $ getEventSubscribedHeight parentSubd
1702− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1741+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1703 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1742 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1704 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1743 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1705 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1744 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1706 )
1745 )
1746+
1707 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1747 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1708 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1748 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1709
1749
1710{-# INLINE [1] mergeCheapWithMove #-}
1750{-# INLINE [1] mergeCheapWithMove #-}
1711−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1751+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1752+ => (forall a. q a -> Event x (v a))
1753+ -> DynamicS x (PatchDMapWithMove k q)
1754+ -> Event x (DMap k v)
1712−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1755+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1713 where
1756 where
1714− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1757+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1715 updateMe subscriber heightBagRef oldParents p = do
1758 updateMe subscriber heightBagRef oldParents p = do
1716 -- Prepare new parents for insertion
1759 -- Prepare new parents for insertion
1717− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1760+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1718 subscribeParent k e = do
1761 subscribeParent k e = do
1719 keyRef <- liftIO $ newIORef k
1762 keyRef <- liftIO $ newIORef k
1720 let s = subscriber $ liftIO $ readIORef keyRef
1763 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1723,9 +1766,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1723 newParentHeight <- getEventSubscribedHeight subd
1766 newParentHeight <- getEventSubscribedHeight subd
1724 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1767 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1725 return $ MergeSubscribedParentWithMove subscription keyRef
1768 return $ MergeSubscribedParentWithMove subscription keyRef
1726− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1769+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1727 -- Collect old parents for deletion and update the keys of moved parents
1770 -- Collect old parents for deletion and update the keys of moved parents
1728− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1771+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1729 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1772 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1730 Nothing -> do
1773 Nothing -> do
1731 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1774 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1736,46 +1779,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1736 return Nothing
1779 return Nothing
1737 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1780 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1738 return (toDelete, applyAlways p' oldParents)
1781 return (toDelete, applyAlways p' oldParents)
1739− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1782+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1740 getInitialSubscribers initialParents subscriber = do
1783 getInitialSubscribers initialParents subscriber = do
1741 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1784 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1742 keyRef <- liftIO $ newIORef k
1785 keyRef <- liftIO $ newIORef k
1743 let s = subscriber $ liftIO $ readIORef keyRef
1786 let s = subscriber $ liftIO $ readIORef keyRef
1744− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1787+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1745 height <- liftIO $ getEventSubscribedHeight parentSubd
1788 height <- liftIO $ getEventSubscribedHeight parentSubd
1746− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1789+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1747 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1790 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1748 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1791 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1749 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1792 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1750 )
1793 )
1794+
1751 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1795 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1752 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1796 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1753
1797
1754−type MergeUpdateFunc k x p s
1798+type MergeUpdateFunc k v x p s
1755− = (forall a. EventM x (k a) -> Subscriber x a)
1799+ = (forall a. EventM x (k a) -> Subscriber x (v a))
1756 -> IORef HeightBag
1800 -> IORef HeightBag
1757 -> DMap k s
1801 -> DMap k s
1758 -> p
1802 -> p
1759 -> EventM x ([EventSubscription x], DMap k s)
1803 -> EventM x ([EventSubscription x], DMap k s)
1760
1804
1761−type MergeInitFunc k x s
1805+type MergeInitFunc k v q x s
1762− = DMap k (Event x)
1806+ = DMap k q
1763− -> (forall a. EventM x (k a) -> Subscriber x a)
1807+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1764− -> EventM x (DMap k Identity, [Height], DMap k s)
1808+ -> EventM x (DMap k v, [Height], DMap k s)
1765
1809
1766type MergeDestroyFunc k s
1810type MergeDestroyFunc k s
1767 = DMap k s
1811 = DMap k s
1768 -> IO ()
1812 -> IO ()
1769
1813
1770−data Merge x k s = Merge
1814+data Merge x k v s = Merge
1771 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1815 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1772 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1816 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1773 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1817 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1774− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1818+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1775− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1819+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1776 }
1820 }
1777
1821
1778−invalidateMergeHeight :: Merge x k s -> IO ()
1822+invalidateMergeHeight :: Merge x k v s -> IO ()
1779invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1823invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1780
1824
1781invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1825invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1785,8 +1829,7 @@ invalidateMergeHeight' heightRef sub = do
1785 writeIORef heightRef $! invalidHeight
1829 writeIORef heightRef $! invalidHeight
1786 subscriberInvalidateHeight sub oldHeight
1830 subscriberInvalidateHeight sub oldHeight
1787
1831
1788−
1789−revalidateMergeHeight :: Merge x k s -> IO ()
1832+revalidateMergeHeight :: Merge x k v s -> IO ()
1790revalidateMergeHeight m = do
1833revalidateMergeHeight m = do
1791 currentHeight <- readIORef $ _merge_heightRef m
1834 currentHeight <- readIORef $ _merge_heightRef m
1792 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1835 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1802,19 +1845,19 @@ revalidateMergeHeight m = do
1802 subscriberRecalculateHeight (_merge_sub m) height
1845 subscriberRecalculateHeight (_merge_sub m) height
1803 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1846 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1804
1847
1805−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1848+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1806scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1849scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1807 vals <- liftIO $ readIORef $ _merge_accumRef m
1850 vals <- liftIO $ readIORef $ _merge_accumRef m
1808 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
1851 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
1809 --TODO: Assert that m is not empty
1852 --TODO: Assert that m is not empty
1810 subscriberPropagate (_merge_sub m) vals
1853 subscriberPropagate (_merge_sub m) vals
1811
1854
1812−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1855+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1813mergeSubscriber m getKey = Subscriber
1856mergeSubscriber m getKey = Subscriber
1814 { subscriberPropagate = \a -> do
1857 { subscriberPropagate = \a -> do
1815 oldM <- liftIO $ readIORef $ _merge_accumRef m
1858 oldM <- liftIO $ readIORef $ _merge_accumRef m
1816 k <- getKey
1859 k <- getKey
1817− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1860+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1818 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1861 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1819 liftIO $ writeIORef (_merge_accumRef m) $! newM
1862 liftIO $ writeIORef (_merge_accumRef m) $! newM
1820 when (DMap.null oldM) $ do -- Only schedule the firing once
1863 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1845,7 +1888,7 @@ mergeSubscriber m getKey = Subscriber
1845 }
1888 }
1846
1889
1847--TODO: Be able to run as much of this as possible promptly
1890--TODO: Be able to run as much of this as possible promptly
1848−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1891+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1849updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1892updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1850 where updateMe = do
1893 where updateMe = do
1851 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1894 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1853,9 +1896,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1853 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1896 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1854 return subscriptionsToKill
1897 return subscriptionsToKill
1855
1898
1856−{-# INLINE mergeCheap' #-}
1899+{-# INLINE mergeGCheap' #-}
1900+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1857−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)
1901+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1858−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1902+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1859 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1903 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1860 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1904 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1861 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1905 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1903,11 +1947,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1903 , occ
1947 , occ
1904 )
1948 )
1905
1949
1906−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1950+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1907mergeInt = cacheEvent . mergeIntCheap
1951mergeInt = cacheEvent . mergeIntCheap
1908
1952
1909{-# INLINABLE mergeIntCheap #-}
1953{-# INLINABLE mergeIntCheap #-}
1910−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1954+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1911mergeIntCheap d = Event $ \sub -> do
1955mergeIntCheap d = Event $ \sub -> do
1912 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1956 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1913 accum <- liftIO $ FastMutableIntMap.newEmpty
1957 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2004,14 +2048,16 @@ mergeIntCheap d = Event $ \sub -> do
2004 )
2048 )
2005
2049
2006newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2050newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2051+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2007
2052
2008−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2053+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2009−fan e =
2054+fanG e = unsafePerformIO $ do
2055+ ref <- newIORef Nothing
2010 let f = Fan
2056 let f = Fan
2011 { fanParent = e
2057 { fanParent = e
2012− , fanSubscribed = unsafeNewIORef e Nothing
2058+ , fanSubscribed = ref
2013 }
2059 }
2014− in EventSelector $ \k -> eventFan k f
2060+ pure $ EventSelectorG $ \k -> eventFan k f
2015
2061
2016runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2062runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2017runHoldInits holdInitRef dynInitRef mergeInitRef = do
2063runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2065,7 +2111,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2065-- | Run an event action outside of a frame
2111-- | Run an event action outside of a frame
2066runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2112runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2067runFrame a = SpiderHost $ do
2113runFrame a = SpiderHost $ do
2068− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2114+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2069 let go = do
2115 let go = do
2070 result <- a
2116 result <- a
2071 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2117 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
@@ -2276,7 +2322,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2276 fail _ = error "Dynamic does not support 'fail'"
2322 fail _ = error "Dynamic does not support 'fail'"
2277
2323
2278{-# INLINABLE newJoinDyn #-}
2324{-# INLINABLE newJoinDyn #-}
2279−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2325+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2280newJoinDyn d =
2326newJoinDyn d =
2281 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2327 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2282 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2328 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2426,7 +2472,7 @@ unsafeNewSpiderTimelineEnv = do
2426#ifdef DEBUG
2472#ifdef DEBUG
2427 depthRef <- newIORef 0
2473 depthRef <- newIORef 0
2428#endif
2474#endif
2429− return $ SpiderTimelineEnv
2475+ return $ STE $ SpiderTimelineEnv
2430 { _spiderTimeline_lock = lock
2476 { _spiderTimeline_lock = lock
2431 , _spiderTimeline_eventEnv = env
2477 , _spiderTimeline_eventEnv = env
2432#ifdef DEBUG
2478#ifdef DEBUG
@@ -2438,17 +2484,17 @@ unsafeNewSpiderTimelineEnv = do
2438newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2484newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2439newSpiderTimeline = withSpiderTimeline (pure . Some)
2485newSpiderTimeline = withSpiderTimeline (pure . Some)
2440
2486
2441−data LocalSpiderTimeline x s
2487+data LocalSpiderTimeline (x :: Type) s
2442
2488
2443instance Reifies s (SpiderTimelineEnv x) =>
2489instance Reifies s (SpiderTimelineEnv x) =>
2444 HasSpiderTimeline (LocalSpiderTimeline x s) where
2490 HasSpiderTimeline (LocalSpiderTimeline x s) where
2445− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2491+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2446
2492
2447localSpiderTimeline
2493localSpiderTimeline
2448− :: Proxy s
2494+ :: proxy s
2449 -> SpiderTimelineEnv x
2495 -> SpiderTimelineEnv x
2450 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2496 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2451−localSpiderTimeline _ = unsafeCoerce
2497+localSpiderTimeline _ = coerce
2452
2498
2453-- | Pass a new timeline to the given function.
2499-- | Pass a new timeline to the given function.
2454withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2500withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2456,18 +2502,18 @@ withSpiderTimeline k = do
2456 env <- unsafeNewSpiderTimelineEnv
2502 env <- unsafeNewSpiderTimelineEnv
2457 reify env $ \s -> k $ localSpiderTimeline s env
2503 reify env $ \s -> k $ localSpiderTimeline s env
2458
2504
2459−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2505+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2460
2506
2461type ComputeM = EventM
2507type ComputeM = EventM
2462
2508
2463−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2509+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2464
2510
2465instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2511instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2466 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2512 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2467 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2513 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2468 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2514 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2469− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2515+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2470− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2516+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2471 type PullM (SpiderTimeline x) = SpiderPullM x
2517 type PullM (SpiderTimeline x) = SpiderPullM x
2472 type PushM (SpiderTimeline x) = SpiderPushM x
2518 type PushM (SpiderTimeline x) = SpiderPushM x
2473 {-# INLINABLE never #-}
2519 {-# INLINABLE never #-}
@@ -2480,10 +2526,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2480 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2526 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2481 {-# INLINABLE pull #-}
2527 {-# INLINABLE pull #-}
2482 pull = SpiderBehavior . pull . coerce
2528 pull = SpiderBehavior . pull . coerce
2483− {-# INLINABLE merge #-}
2529+ {-# INLINABLE fanG #-}
2484− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2485− {-# INLINABLE fan #-}
2486− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2530+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2531+ {-# INLINABLE mergeG #-}
2532+ mergeG
2533+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2534+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2535+ -> DMap k q
2536+ -> R.Event (SpiderTimeline x) (DMap k v)
2537+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2487 {-# INLINABLE switch #-}
2538 {-# INLINABLE switch #-}
2488 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2539 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2489 {-# INLINABLE coincidence #-}
2540 {-# INLINABLE coincidence #-}
@@ -2491,15 +2542,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2491 {-# INLINABLE current #-}
2542 {-# INLINABLE current #-}
2492 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2543 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2493 {-# INLINABLE updated #-}
2544 {-# INLINABLE updated #-}
2494− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2545+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2495 {-# INLINABLE unsafeBuildDynamic #-}
2546 {-# INLINABLE unsafeBuildDynamic #-}
2496 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2547 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2497 {-# INLINABLE unsafeBuildIncremental #-}
2548 {-# INLINABLE unsafeBuildIncremental #-}
2498 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2549 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2499− {-# INLINABLE mergeIncremental #-}
2550+ {-# INLINABLE mergeIncrementalG #-}
2500− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2551+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2501− {-# INLINABLE mergeIncrementalWithMove #-}
2552+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2502− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2553+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2503 {-# INLINABLE currentIncremental #-}
2554 {-# INLINABLE currentIncremental #-}
2504 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2555 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2505 {-# INLINABLE updatedIncremental #-}
2556 {-# INLINABLE updatedIncremental #-}
@@ -2510,9 +2561,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2510 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2561 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2511 eventCoercion Coercion = Coercion
2562 eventCoercion Coercion = Coercion
2512 behaviorCoercion Coercion = Coercion
2563 behaviorCoercion Coercion = Coercion
2513− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2564+ dynamicCoercion Coercion = Coercion
2565+ incrementalCoercion Coercion Coercion = Coercion
2514 {-# INLINABLE mergeIntIncremental #-}
2566 {-# INLINABLE mergeIntIncremental #-}
2515− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2567+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
2516 {-# INLINABLE fanInt #-}
2568 {-# INLINABLE fanInt #-}
2517 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2569 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2518
2570
@@ -2537,7 +2589,7 @@ instance MonadAtomicRef (EventM x) where
2537 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2589 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2538
2590
2539-- | The monad for actions that manipulate a Spider timeline identified by @x@
2591-- | The monad for actions that manipulate a Spider timeline identified by @x@
2540−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2592+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2541
2593
2542instance Monad (SpiderHost x) where
2594instance Monad (SpiderHost x) where
2543 {-# INLINABLE (>>=) #-}
2595 {-# INLINABLE (>>=) #-}
@@ -2559,7 +2611,7 @@ runSpiderHost (SpiderHost a) = a
2559runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2611runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2560runSpiderHostForTimeline (SpiderHost a) _ = a
2612runSpiderHostForTimeline (SpiderHost a) _ = a
2561
2613
2562−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2614+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2563 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2615 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2564
2616
2565instance Monad (SpiderHostFrame x) where
2617instance Monad (SpiderHostFrame x) where
test/GC.hs+4−3
@@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S
27
27
28import System.Exit
28import System.Exit
29import System.Mem
29import System.Mem
30+import Data.Coerce
30
31
31main :: IO ()
32main :: IO ()
32main = do
33main = do
@@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do
46 eventToPerform <- Host.runHostFrame $ do
47 eventToPerform <- Host.runHostFrame $ do
47 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
48 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
48 <- S.SpiderHostFrame
49 <- S.SpiderHostFrame
49− $ fmap ( S.merge
50+ $ fmap ( S.mergeG coerce
50 . S.dynamicHold)
51 . S.dynamicHold)
51 $ S.hold DMap.empty
52 $ S.hold DMap.empty
52 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
53 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
@@ -55,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do
55 { S.subscriberPropagate = S.subscriberPropagate sub
56 { S.subscriberPropagate = S.subscriberPropagate sub
56 }
57 }
57 return (s, o))
58 return (s, o))
58− $ runIdentity <$> S.select
59+ $ runIdentity . runIdentity <$> S.selectG
59− (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60+ (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60 (WrapArg Request)
61 (WrapArg Request)
61 return $ alignWith (mergeThese (<>))
62 return $ alignWith (mergeThese (<>))
62 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
test/Reflex/Bench/Focused.hs+12
@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132
132
133+holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))
135+
136+buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
137+buildDynChain = iterM (\d -> do
138+ let b = fmap (+1) (current d)
139+ e = fmap (*2) (updated d)
140+ buildDynamic (sample b) e)
141+
142+
133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
135
145
@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]
308dynamics n =
318dynamics n =
309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse