git.iko.soy/reflex
on develop help sign in
Generalize merge
8d8ceecDavid Feuer
ChangeLog.md+4
compare with develop
unifiedsplit
@@ -3,6 +3,10 @@
3## Unreleased
3## Unreleased
4
4
5* Fix `holdDyn` so that it is lazy in its event argument
5* Fix `holdDyn` so that it is lazy in its event argument
6+* Generalize `merge` to `mergeG`, `mergeIncremental` to
7+ `mergeIncrementalG`, and `mergeIncrementalWithMove`
8+ to `mergeIncrementalWithMoveG`. These produce `DMap`s
9+ whose values needn't be `Identity`.
6
10
7## 0.6.1.0
11## 0.6.1.0
8
12
reflex.cabal+1
@@ -48,6 +48,7 @@ library
48 data-default >= 0.5 && < 0.8,
48 data-default >= 0.5 && < 0.8,
49 dependent-map >= 0.2.4 && < 0.3,
49 dependent-map >= 0.2.4 && < 0.3,
50 exception-transformers == 0.4.*,
50 exception-transformers == 0.4.*,
51+ profunctors,
51 lens >= 4.7 && < 5,
52 lens >= 4.7 && < 5,
52 monad-control >= 1.0.1 && < 1.1,
53 monad-control >= 1.0.1 && < 1.1,
53 monoidal-containers == 0.4.*,
54 monoidal-containers == 0.4.*,
src/Reflex/Class.hs+31−3
@@ -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
@@ -46,6 +47,9 @@ module Reflex.Class
46 , pushAlways
47 , pushAlways
47 -- ** Combining 'Event's
48 -- ** Combining 'Event's
48 , leftmost
49 , leftmost
50+ , merge
51+ , mergeIncremental
52+ , mergeIncrementalWithMove
49 , mergeMap
53 , mergeMap
50 , mergeIntMap
54 , mergeIntMap
51 , mergeMapIncremental
55 , mergeMapIncremental
@@ -256,7 +260,9 @@ class ( MonadHold t (PushM t)
256 -- | Merge a collection of events; the resulting 'Event' will only occur if at
260 -- | Merge a collection of events; the resulting 'Event' will only occur if at
257 -- least one input event is occurring, and will contain all of the input keys
261 -- least one input event is occurring, and will contain all of the input keys
258 -- that are occurring simultaneously
262 -- that are occurring simultaneously
263+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))
264+ -> DMap k q -> Event t (DMap k v)
259− 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
265+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
260 -- | Efficiently fan-out an event to many destinations. You should save the
266 -- | Efficiently fan-out an event to many destinations. You should save the
261 -- result in a @let@-binding, and then repeatedly 'select' on the result to
267 -- result in a @let@-binding, and then repeatedly 'select' on the result to
262 -- create child events
268 -- create child events
@@ -278,9 +284,14 @@ class ( MonadHold t (PushM t)
278 -- that value.
284 -- that value.
279 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
285 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
280 -- | Create a merge whose parents can change over time
286 -- | Create a merge whose parents can change over time
287+ mergeIncrementalG :: GCompare k
288+ => (forall a. q a -> Event t (v a))
281− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
289+ -> Incremental t (PatchDMap k q)
290+ -> Event t (DMap k v)
282 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
291 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
292+ mergeIncrementalWithMoveG :: GCompare k
293+ => (forall a. q a -> Event t (v a))
283− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
294+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
284 -- | Extract the 'Behavior' component of an 'Incremental'
295 -- | Extract the 'Behavior' component of an 'Incremental'
285 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
296 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
286 -- | Extract the 'Event' component of an 'Incremental'
297 -- | Extract the 'Event' component of an 'Incremental'
@@ -1558,6 +1569,23 @@ fmapCheap f = pushCheap $ return . Just . f
1558tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1569tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1559tagCheap b = pushAlwaysCheap $ \_ -> sample b
1570tagCheap b = pushAlwaysCheap $ \_ -> sample b
1560
1571
1572+-- | Merge a collection of events; the resulting 'Event' will only occur if at
1573+-- least one input event is occurring, and will contain all of the input keys
1574+-- that are occurring simultaneously
1575+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
1576+merge = mergeG coerceEvent
1577+{-# INLINE merge #-}
1578+
1579+-- | Create a merge whose parents can change over time
1580+mergeIncremental :: (Reflex t, GCompare k)
1581+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
1582+mergeIncremental = mergeIncrementalG coerceEvent
1583+
1584+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
1585+mergeIncrementalWithMove :: (Reflex t, GCompare k)
1586+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
1587+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent
1588+
1561-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
1589-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
1562{-# INLINE mergeWithCheap #-}
1590{-# INLINE mergeWithCheap #-}
1563mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1591mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
src/Reflex/Profiled.hs+9−5
@@ -8,6 +8,8 @@
8{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-}
11-- |
13-- |
12-- Module:
14-- Module:
13-- Reflex.Profiled
15-- Reflex.Profiled
@@ -16,7 +18,6 @@
16-- profiling/cost-center information.
18-- profiling/cost-center information.
17module Reflex.Profiled where
19module Reflex.Profiled where
18
20
19−import Control.Lens hiding (children)
20import Control.Monad
21import Control.Monad
21import Control.Monad.Exception
22import Control.Monad.Exception
22import Control.Monad.Fix
23import Control.Monad.Fix
@@ -33,6 +34,7 @@ import Data.Map (Map)
33import qualified Data.Map.Strict as Map
34import qualified Data.Map.Strict as Map
34import Data.Monoid ((<>))
35import Data.Monoid ((<>))
35import Data.Ord
36import Data.Ord
37+import Data.Profunctor.Unsafe ((#.))
36import qualified Data.Semigroup as S
38import qualified Data.Semigroup as S
37import Data.Type.Coercion
39import Data.Type.Coercion
38import Foreign.Ptr
40import Foreign.Ptr
@@ -133,8 +135,10 @@ 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
135 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
136 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
135 pull = Behavior_Profiled . pull . coerce
137 pull = Behavior_Profiled . pull . coerce
138+ mergeG :: forall (k :: z -> *) q v. GCompare k
139+ => (forall a. q a -> Event (ProfiledTimeline t) (v a))
136− merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
140+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
137− merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
141+ mergeG nt = Event_Profiled #. mergeG (coerce nt)
138 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
142 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
143 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
144 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
@@ -142,8 +146,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
146 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
147 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
144 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
148 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)))
149+ 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)))
150+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
src/Reflex/Pure.hs+16−10
@@ -5,6 +5,8 @@
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE PolyKinds #-}
8#ifdef USE_REFLEX_OPTIMIZER
10#ifdef USE_REFLEX_OPTIMIZER
9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10#endif
12#endif
@@ -43,10 +45,11 @@ import Data.MemoTrie
43import Data.Monoid
45import Data.Monoid
44import Data.Type.Coercion
46import Data.Type.Coercion
45import Reflex.Class
47import Reflex.Class
48+import Data.Kind (Type)
46
49
47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
50-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
48-- with the type @/t/@.
51-- with the type @/t/@.
49−data Pure t
52+data Pure (t :: Type)
50
53
51-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
54-- | 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
55-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
@@ -79,11 +82,12 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
79 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
82 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
80 -- warning because the GCompare instance is not used; however, removing the
83 -- warning because the GCompare instance is not used; however, removing the
81 -- GCompare instance produces a different warning, due to that constraint
84 -- GCompare instance produces a different warning, due to that constraint
82− -- being present in the original class definition
85+ -- being present in the original class definition.
83
86
84− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
87+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
88+ -- -> DMap k q -> Event (Pure t) (DMap k v)
85− merge events = Event $ memo $ \t ->
89+ mergeG nt events = Event $ memo $ \t ->
86− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
90+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
87 in if DMap.null currentOccurrences
91 in if DMap.null currentOccurrences
88 then Nothing
92 then Nothing
89 else Just currentOccurrences
93 else Just currentOccurrences
@@ -112,8 +116,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
112 --a) -> Incremental (Pure t) p a
116 --a) -> Incremental (Pure t) p a
113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
117 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
114
118
115− mergeIncremental = mergeIncrementalImpl
119+ mergeIncrementalG = mergeIncrementalImpl
116− mergeIncrementalWithMove = mergeIncrementalImpl
120+ mergeIncrementalWithMoveG = mergeIncrementalImpl
117
121
118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
122 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
119
123
@@ -133,9 +137,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
133
137
134 mergeIntIncremental = mergeIntIncrementalImpl
138 mergeIntIncremental = mergeIntIncrementalImpl
135
139
136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
140+mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
141+ => (forall a. q a -> Event (Pure t) (v a))
142+ -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
137−mergeIncrementalImpl i = Event $ \t ->
143+mergeIncrementalImpl nt i = Event $ \t ->
138− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
144+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
139 in if DMap.null results
145 in if DMap.null results
140 then Nothing
146 then Nothing
141 else Just results
147 else Just results
src/Reflex/Spider/Internal.hs+78−53
@@ -17,9 +17,12 @@
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE InstanceSigs #-}
20#ifdef USE_REFLEX_OPTIMIZER
22#ifdef USE_REFLEX_OPTIMIZER
21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
23{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22#endif
24#endif
25+{-# OPTIONS_GHC -Wunused-binds #-}
23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
26-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
27-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
28module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -49,6 +52,7 @@ import Data.GADT.Compare
49import Data.IntMap.Strict (IntMap)
52import Data.IntMap.Strict (IntMap)
50import qualified Data.IntMap.Strict as IntMap
53import qualified Data.IntMap.Strict as IntMap
51import Data.IORef
54import Data.IORef
55+import Data.Kind (Type)
52import Data.Maybe hiding (mapMaybe)
56import Data.Maybe hiding (mapMaybe)
53import Data.Monoid ((<>))
57import Data.Monoid ((<>))
54import Data.Proxy
58import Data.Proxy
@@ -77,6 +81,7 @@ import Data.Reflection
77import Data.Some (Some)
81import Data.Some (Some)
78import qualified Data.Some as Some
82import qualified Data.Some as Some
79import Data.Type.Coercion
83import Data.Type.Coercion
84+import Data.Profunctor.Unsafe ((#.), (.#))
80import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
85import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
81import qualified Data.WeakBag as WeakBag
86import qualified Data.WeakBag as WeakBag
82import qualified Reflex.Class
87import qualified Reflex.Class
@@ -1136,13 +1141,14 @@ instance HasSpiderTimeline x => Align (Event x) where
1136#if MIN_VERSION_these(0, 8, 0)
1141#if MIN_VERSION_these(0, 8, 0)
1137instance HasSpiderTimeline x => Semialign (Event x) where
1142instance HasSpiderTimeline x => Semialign (Event x) where
1138#endif
1143#endif
1144+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1139− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1145+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1140
1146
1141data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1147data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1142 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1148 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1143 | HoldDyn !(Hold x p)
1149 | HoldDyn !(Hold x p)
1144
1150
1145−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1151+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1146
1152
1147newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1153newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1148newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1154newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
@@ -1688,26 +1694,34 @@ cleanupCoincidenceSubscribed subscribed = do
1688subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1694subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1689subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1695subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1690
1696
1691−{-# INLINE merge #-}
1697+{-# INLINE mergeG #-}
1692−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+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)
1693−merge d = cacheEvent (mergeCheap d)
1701+mergeG nt d = cacheEvent (mergeCheap nt d)
1694
1702
1695{-# INLINE mergeWithMove #-}
1703{-# INLINE mergeWithMove #-}
1696−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+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)
1697−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1707+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1698
1708
1699{-# INLINE [1] mergeCheap #-}
1709{-# INLINE [1] mergeCheap #-}
1710+mergeCheap
1700−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+ -> Dynamic x (PatchDMap k q)
1714+ -> Event x (DMap k v)
1701−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1715+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1702 where
1716 where
1703− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1717+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1704 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1718 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1705 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1719 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1706 (mOldSubd, newPs) <- case me of
1720 (mOldSubd, newPs) <- case me of
1707 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1721 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1708 Just e -> do
1722 Just e -> do
1709 let s = subscriber $ return k
1723 let s = subscriber $ return k
1710− subscription@(EventSubscription _ subd) <- subscribe e s
1724+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1711 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1725 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1712 let newParent = MergeSubscribedParent subscription
1726 let newParent = MergeSubscribedParent subscription
1713 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1727 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1717,28 +1731,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1717 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1731 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1718 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1732 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1719 foldM f ([], oldParents) $ DMap.toList p
1733 foldM f ([], oldParents) $ DMap.toList p
1734+
1720− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1735+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1721 getInitialSubscribers initialParents subscriber = do
1736 getInitialSubscribers initialParents subscriber = do
1722 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1737 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1723 let s = subscriber $ return k
1738 let s = subscriber $ return k
1724− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1739+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1725 height <- liftIO $ getEventSubscribedHeight parentSubd
1740 height <- liftIO $ getEventSubscribedHeight parentSubd
1726− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1741+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1727 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1742 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1728 , 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
1729 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1744 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1730 )
1745 )
1746+
1731 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1747 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1732 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1748 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1733
1749
1734{-# INLINE [1] mergeCheapWithMove #-}
1750{-# INLINE [1] mergeCheapWithMove #-}
1735−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+ -> Dynamic x (PatchDMapWithMove k q)
1754+ -> Event x (DMap k v)
1736−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1755+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1737 where
1756 where
1738− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1757+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1739 updateMe subscriber heightBagRef oldParents p = do
1758 updateMe subscriber heightBagRef oldParents p = do
1740 -- Prepare new parents for insertion
1759 -- Prepare new parents for insertion
1741− 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)
1742 subscribeParent k e = do
1761 subscribeParent k e = do
1743 keyRef <- liftIO $ newIORef k
1762 keyRef <- liftIO $ newIORef k
1744 let s = subscriber $ liftIO $ readIORef keyRef
1763 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1747,9 +1766,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1747 newParentHeight <- getEventSubscribedHeight subd
1766 newParentHeight <- getEventSubscribedHeight subd
1748 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1767 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1749 return $ MergeSubscribedParentWithMove subscription keyRef
1768 return $ MergeSubscribedParentWithMove subscription keyRef
1750− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1769+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1751 -- 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
1752− 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
1753 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1772 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1754 Nothing -> do
1773 Nothing -> do
1755 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1774 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1760,46 +1779,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1760 return Nothing
1779 return Nothing
1761 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
1762 return (toDelete, applyAlways p' oldParents)
1781 return (toDelete, applyAlways p' oldParents)
1763− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1782+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1764 getInitialSubscribers initialParents subscriber = do
1783 getInitialSubscribers initialParents subscriber = do
1765 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1784 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1766 keyRef <- liftIO $ newIORef k
1785 keyRef <- liftIO $ newIORef k
1767 let s = subscriber $ liftIO $ readIORef keyRef
1786 let s = subscriber $ liftIO $ readIORef keyRef
1768− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1787+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1769 height <- liftIO $ getEventSubscribedHeight parentSubd
1788 height <- liftIO $ getEventSubscribedHeight parentSubd
1770− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1789+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1771 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1790 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1772 , 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
1773 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1792 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1774 )
1793 )
1794+
1775 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1795 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1776 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1796 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1777
1797
1778−type MergeUpdateFunc k x p s
1798+type MergeUpdateFunc k v x p s
1779− = (forall a. EventM x (k a) -> Subscriber x a)
1799+ = (forall a. EventM x (k a) -> Subscriber x (v a))
1780 -> IORef HeightBag
1800 -> IORef HeightBag
1781 -> DMap k s
1801 -> DMap k s
1782 -> p
1802 -> p
1783 -> EventM x ([EventSubscription x], DMap k s)
1803 -> EventM x ([EventSubscription x], DMap k s)
1784
1804
1785−type MergeInitFunc k x s
1805+type MergeInitFunc k v q x s
1786− = DMap k (Event x)
1806+ = DMap k q
1787− -> (forall a. EventM x (k a) -> Subscriber x a)
1807+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1788− -> EventM x (DMap k Identity, [Height], DMap k s)
1808+ -> EventM x (DMap k v, [Height], DMap k s)
1789
1809
1790type MergeDestroyFunc k s
1810type MergeDestroyFunc k s
1791 = DMap k s
1811 = DMap k s
1792 -> IO ()
1812 -> IO ()
1793
1813
1794−data Merge x k s = Merge
1814+data Merge x k v s = Merge
1795 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1815 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1796 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1816 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1797 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1817 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1798− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1818+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1799− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1819+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1800 }
1820 }
1801
1821
1802−invalidateMergeHeight :: Merge x k s -> IO ()
1822+invalidateMergeHeight :: Merge x k v s -> IO ()
1803invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1823invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1804
1824
1805invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1825invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1809,8 +1829,7 @@ invalidateMergeHeight' heightRef sub = do
1809 writeIORef heightRef $! invalidHeight
1829 writeIORef heightRef $! invalidHeight
1810 subscriberInvalidateHeight sub oldHeight
1830 subscriberInvalidateHeight sub oldHeight
1811
1831
1812−
1813−revalidateMergeHeight :: Merge x k s -> IO ()
1832+revalidateMergeHeight :: Merge x k v s -> IO ()
1814revalidateMergeHeight m = do
1833revalidateMergeHeight m = do
1815 currentHeight <- readIORef $ _merge_heightRef m
1834 currentHeight <- readIORef $ _merge_heightRef m
1816 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
@@ -1826,19 +1845,19 @@ revalidateMergeHeight m = do
1826 subscriberRecalculateHeight (_merge_sub m) height
1845 subscriberRecalculateHeight (_merge_sub m) height
1827 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"
1828
1847
1829−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1848+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1830scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1849scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1831 vals <- liftIO $ readIORef $ _merge_accumRef m
1850 vals <- liftIO $ readIORef $ _merge_accumRef m
1832 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
1833 --TODO: Assert that m is not empty
1852 --TODO: Assert that m is not empty
1834 subscriberPropagate (_merge_sub m) vals
1853 subscriberPropagate (_merge_sub m) vals
1835
1854
1836−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)
1837mergeSubscriber m getKey = Subscriber
1856mergeSubscriber m getKey = Subscriber
1838 { subscriberPropagate = \a -> do
1857 { subscriberPropagate = \a -> do
1839 oldM <- liftIO $ readIORef $ _merge_accumRef m
1858 oldM <- liftIO $ readIORef $ _merge_accumRef m
1840 k <- getKey
1859 k <- getKey
1841− 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
1842 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)
1843 liftIO $ writeIORef (_merge_accumRef m) $! newM
1862 liftIO $ writeIORef (_merge_accumRef m) $! newM
1844 when (DMap.null oldM) $ do -- Only schedule the firing once
1863 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1869,7 +1888,7 @@ mergeSubscriber m getKey = Subscriber
1869 }
1888 }
1870
1889
1871--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
1872−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
1873updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1892updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1874 where updateMe = do
1893 where updateMe = do
1875 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1894 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1877,9 +1896,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1877 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1896 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1878 return subscriptionsToKill
1897 return subscriptionsToKill
1879
1898
1880−{-# INLINE mergeCheap' #-}
1899+{-# INLINE mergeGCheap' #-}
1900+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1881−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 -> Dynamic x p -> Event x (DMap k v)
1882−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1902+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1883 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1903 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1884 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1904 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1885 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1905 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -2462,7 +2482,7 @@ unsafeNewSpiderTimelineEnv = do
2462newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2482newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2463newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2483newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2464
2484
2465−data LocalSpiderTimeline x s
2485+data LocalSpiderTimeline (x :: Type) s
2466
2486
2467instance Reifies s (SpiderTimelineEnv x) =>
2487instance Reifies s (SpiderTimelineEnv x) =>
2468 HasSpiderTimeline (LocalSpiderTimeline x s) where
2488 HasSpiderTimeline (LocalSpiderTimeline x s) where
@@ -2480,11 +2500,11 @@ withSpiderTimeline k = do
2480 env <- unsafeNewSpiderTimelineEnv
2500 env <- unsafeNewSpiderTimelineEnv
2481 reify env $ \s -> k $ localSpiderTimeline s env
2501 reify env $ \s -> k $ localSpiderTimeline s env
2482
2502
2483−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2503+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2484
2504
2485type ComputeM = EventM
2505type ComputeM = EventM
2486
2506
2487−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2507+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2488
2508
2489instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2509instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2490 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2510 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
@@ -2504,8 +2524,13 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2504 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2524 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2505 {-# INLINABLE pull #-}
2525 {-# INLINABLE pull #-}
2506 pull = SpiderBehavior . pull . coerce
2526 pull = SpiderBehavior . pull . coerce
2507− {-# INLINABLE merge #-}
2527+ {-# INLINABLE mergeG #-}
2508− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2528+ mergeG
2529+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2530+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2531+ -> DMap k q
2532+ -> R.Event (SpiderTimeline x) (DMap k v)
2533+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2509 {-# INLINABLE fan #-}
2534 {-# INLINABLE fan #-}
2510 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2535 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2511 {-# INLINABLE switch #-}
2536 {-# INLINABLE switch #-}
@@ -2520,10 +2545,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2520 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2545 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2521 {-# INLINABLE unsafeBuildIncremental #-}
2546 {-# INLINABLE unsafeBuildIncremental #-}
2522 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2547 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2523− {-# INLINABLE mergeIncremental #-}
2548+ {-# INLINABLE mergeIncrementalG #-}
2524− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2549+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2525− {-# INLINABLE mergeIncrementalWithMove #-}
2550+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2526− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2551+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2527 {-# INLINABLE currentIncremental #-}
2552 {-# INLINABLE currentIncremental #-}
2528 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2553 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2529 {-# INLINABLE updatedIncremental #-}
2554 {-# INLINABLE updatedIncremental #-}
@@ -2561,7 +2586,7 @@ instance MonadAtomicRef (EventM x) where
2561 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2586 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2562
2587
2563-- | The monad for actions that manipulate a Spider timeline identified by @x@
2588-- | The monad for actions that manipulate a Spider timeline identified by @x@
2564−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2589+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2565
2590
2566instance Monad (SpiderHost x) where
2591instance Monad (SpiderHost x) where
2567 {-# INLINABLE (>>=) #-}
2592 {-# INLINABLE (>>=) #-}
@@ -2583,7 +2608,7 @@ runSpiderHost (SpiderHost a) = a
2583runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2608runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2584runSpiderHostForTimeline (SpiderHost a) _ = a
2609runSpiderHostForTimeline (SpiderHost a) _ = a
2585
2610
2586−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2611+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2587 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2612 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2588
2613
2589instance Monad (SpiderHostFrame x) where
2614instance Monad (SpiderHostFrame x) where
test/GC.hs+2−1
@@ -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