on develop help sign in
Merge pull request #320 from treeowl/canhazmerge

Generalize merge(s) to allow non Identity functors in DMap.

commit9afdfce554b8db949f23c2f1b52bfc8a9317d4b4 authorOliver Batchelor <saulzar@gmail.com> dateSun 21 Jul 2019, 16:31 (7 years ago) parentbccbe42e5d5946
7 files changed+161−76
ChangeLog.md+10 reflex.cabal+1 src/Reflex/Class.hs+45−7 src/Reflex/Profiled.hs+9−5 src/Reflex/Pure.hs+16−10 src/Reflex/Spider/Internal.hs+78−53 test/GC.hs+2−1
ChangeLog.md+10
@@ -1,7 +1,17 @@
11# Revision history for reflex
22
3+## Unreleased
4+
5+* Generalize merging functions:
6+ `merge` to `mergeG`,
7+ `mergeIncremental` to `mergeIncrementalG`,
8+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
9+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
10+
311## 0.6.2.0
412
13+* Fix `holdDyn` so that it is lazy in its event argument
14+ These produce `DMap`s whose values needn't be `Identity`.
515* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
616* Fix `holdDyn` so that it is lazy in its event argument.
717
reflex.cabal+1
@@ -49,6 +49,7 @@ library
4949 data-default >= 0.5 && < 0.8,
5050 dependent-map >= 0.3 && < 0.4,
5151 exception-transformers == 0.4.*,
52+ profunctors,
5253 lens >= 4.7 && < 5,
5354 monad-control >= 1.0.1 && < 1.1,
5455 monoidal-containers == 0.4.*,
src/Reflex/Class.hs+45−7
@@ -17,6 +17,7 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE Trustworthy #-}
2021#ifdef USE_REFLEX_OPTIMIZER
2122{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2223#endif
@@ -46,6 +47,9 @@ module Reflex.Class
4647 , pushAlways
4748 -- ** Combining 'Event's
4849 , leftmost
50+ , merge
51+ , mergeIncremental
52+ , mergeIncrementalWithMove
4953 , mergeMap
5054 , mergeIntMap
5155 , mergeMapIncremental
@@ -84,6 +88,7 @@ module Reflex.Class
8488 , gate
8589 -- ** Combining 'Dynamic's
8690 , distributeDMapOverDynPure
91+ , distributeDMapOverDynPureG
8792 , distributeListOverDyn
8893 , distributeListOverDynWith
8994 , zipDyn
@@ -255,7 +260,9 @@ class ( MonadHold t (PushM t)
255260 -- | Merge a collection of events; the resulting 'Event' will only occur if at
256261 -- least one input event is occurring, and will contain all of the input keys
257262 -- that are occurring simultaneously
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
263+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))
264+ -> DMap k q -> Event t (DMap k v)
265+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
259266 -- | Efficiently fan-out an event to many destinations. You should save the
260267 -- result in a @let@-binding, and then repeatedly 'select' on the result to
261268 -- create child events
@@ -277,9 +284,14 @@ class ( MonadHold t (PushM t)
277284 -- that value.
278285 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
279286 -- | Create a merge whose parents can change over time
280− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
287+ mergeIncrementalG :: GCompare k
288+ => (forall a. q a -> Event t (v a))
289+ -> Incremental t (PatchDMap k q)
290+ -> Event t (DMap k v)
281291 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
282− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
292+ mergeIncrementalWithMoveG :: GCompare k
293+ => (forall a. q a -> Event t (v a))
294+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
283295 -- | Extract the 'Behavior' component of an 'Incremental'
284296 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
285297 -- | Extract the 'Event' component of an 'Incremental'
@@ -1079,12 +1091,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
10791091-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
10801092-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
10811093distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1082−distributeDMapOverDynPure dm = case DMap.toList dm of
1094+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic
1095+
1096+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1097+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1098+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1099+distributeDMapOverDynPureG
1100+ :: forall t k q v. (Reflex t, GCompare k)
1101+ => (forall a. q a -> Dynamic t (v a))
1102+ -> DMap k q -> Dynamic t (DMap k v)
1103+distributeDMapOverDynPureG nt dm = case DMap.toList dm of
10831104 [] -> constDyn DMap.empty
1084− [k :=> v] -> fmap (DMap.singleton k . Identity) v
1105+ [k :=> v] -> DMap.singleton k <$> nt v
10851106 _ ->
1086− let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1087− edmPre = merge $ DMap.map updated dm
1107+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1108+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
10881109 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
10891110 olds <- sample $ current result
10901111 return $ DMap.unionWithKey (\_ _ new -> new) olds news
@@ -1557,6 +1578,23 @@ fmapCheap f = pushCheap $ return . Just . f
15571578tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
15581579tagCheap b = pushAlwaysCheap $ \_ -> sample b
15591580
1581+-- | Merge a collection of events; the resulting 'Event' will only occur if at
1582+-- least one input event is occurring, and will contain all of the input keys
1583+-- that are occurring simultaneously
1584+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
1585+merge = mergeG coerceEvent
1586+{-# INLINE merge #-}
1587+
1588+-- | Create a merge whose parents can change over time
1589+mergeIncremental :: (Reflex t, GCompare k)
1590+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
1591+mergeIncremental = mergeIncrementalG coerceEvent
1592+
1593+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
1594+mergeIncrementalWithMove :: (Reflex t, GCompare k)
1595+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
1596+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent
1597+
15601598-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
15611599{-# INLINE mergeWithCheap #-}
15621600mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
src/Reflex/Profiled.hs+9−5
@@ -8,6 +8,8 @@
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeFamilies #-}
1010{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-}
1113-- |
1214-- Module:
1315-- Reflex.Profiled
@@ -16,7 +18,6 @@
1618-- profiling/cost-center information.
1719module Reflex.Profiled where
1820
19−import Control.Lens hiding (children)
2021import Control.Monad
2122import Control.Monad.Exception
2223import Control.Monad.Fix
@@ -33,6 +34,7 @@ import Data.Map (Map)
3334import qualified Data.Map.Strict as Map
3435import Data.Monoid ((<>))
3536import Data.Ord
37+import Data.Profunctor.Unsafe ((#.))
3638import qualified Data.Semigroup as S
3739import Data.Type.Coercion
3840import Foreign.Ptr
@@ -133,8 +135,10 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
133135 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
134136 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
135137 pull = Behavior_Profiled . pull . coerce
136− merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
137− merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
138+ mergeG :: forall (k :: z -> *) q v. GCompare k
139+ => (forall a. q a -> Event (ProfiledTimeline t) (v a))
140+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
141+ mergeG nt = Event_Profiled #. mergeG (coerce nt)
138142 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
139143 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
140144 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
@@ -142,8 +146,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
142146 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
143147 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
144148 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)))
146− mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
149+ mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
150+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
147151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
148152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
149153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
src/Reflex/Pure.hs+16−10
@@ -5,6 +5,8 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE ScopedTypeVariables #-}
77{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE PolyKinds #-}
810#ifdef USE_REFLEX_OPTIMIZER
911{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1012#endif
@@ -43,10 +45,11 @@ import Data.MemoTrie
4345import Data.Monoid
4446import Data.Type.Coercion
4547import Reflex.Class
48+import Data.Kind (Type)
4649
4750-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
4851-- with the type @/t/@.
49−data Pure t
52+data Pure (t :: Type)
5053
5154-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
5255-- 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
7982 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
8083 -- warning because the GCompare instance is not used; however, removing the
8184 -- 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.
8386
84− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
85− merge events = Event $ memo $ \t ->
86− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
87+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
88+ -- -> DMap k q -> Event (Pure t) (DMap k v)
89+ mergeG nt events = Event $ memo $ \t ->
90+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
8791 in if DMap.null currentOccurrences
8892 then Nothing
8993 else Just currentOccurrences
@@ -112,8 +116,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
112116 --a) -> Incremental (Pure t) p a
113117 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
114118
115− mergeIncremental = mergeIncrementalImpl
116− mergeIncrementalWithMove = mergeIncrementalImpl
119+ mergeIncrementalG = mergeIncrementalImpl
120+ mergeIncrementalWithMoveG = mergeIncrementalImpl
117121
118122 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
119123
@@ -133,9 +137,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
133137
134138 mergeIntIncremental = mergeIntIncrementalImpl
135139
136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
137−mergeIncrementalImpl i = Event $ \t ->
138− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
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)
143+mergeIncrementalImpl nt i = Event $ \t ->
144+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
139145 in if DMap.null results
140146 then Nothing
141147 else Just results
src/Reflex/Spider/Internal.hs+78−53
@@ -17,9 +17,12 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE InstanceSigs #-}
2022#ifdef USE_REFLEX_OPTIMIZER
2123{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2224#endif
25+{-# OPTIONS_GHC -Wunused-binds #-}
2326-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2427-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2528module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -49,6 +52,7 @@ import Data.GADT.Compare
4952import Data.IntMap.Strict (IntMap)
5053import qualified Data.IntMap.Strict as IntMap
5154import Data.IORef
55+import Data.Kind (Type)
5256import Data.Maybe hiding (mapMaybe)
5357import Data.Monoid ((<>))
5458import Data.Proxy
@@ -76,6 +80,7 @@ import qualified Data.FastWeakBag as FastWeakBag
7680import Data.Reflection
7781import Data.Some (Some(Some))
7882import Data.Type.Coercion
83+import Data.Profunctor.Unsafe ((#.), (.#))
7984import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
8085import qualified Data.WeakBag as WeakBag
8186import qualified Reflex.Class
@@ -1135,13 +1140,14 @@ instance HasSpiderTimeline x => Align (Event x) where
11351140#if MIN_VERSION_these(0, 8, 0)
11361141instance HasSpiderTimeline x => Semialign (Event x) where
11371142#endif
1138− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1143+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1144+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
11391145
11401146data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
11411147 | BuildDyn !(EventM x (PatchTarget p), Event x p)
11421148 | HoldDyn !(Hold x p)
11431149
1144−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1150+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
11451151
11461152newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
11471153newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
@@ -1687,26 +1693,34 @@ cleanupCoincidenceSubscribed subscribed = do
16871693subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
16881694subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
16891695
1690−{-# INLINE merge #-}
1691−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1692−merge d = cacheEvent (mergeCheap d)
1696+{-# INLINE mergeG #-}
1697+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1698+ => (forall a. q a -> Event x (v a))
1699+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)
1700+mergeG nt d = cacheEvent (mergeCheap nt d)
16931701
16941702{-# INLINE mergeWithMove #-}
1695−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1696−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1703+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1704+ => (forall a. q a -> Event x (v a))
1705+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)
1706+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
16971707
16981708{-# INLINE [1] mergeCheap #-}
1699−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1700−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1709+mergeCheap
1710+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1711+ => (forall a. q a -> Event x (v a))
1712+ -> Dynamic x (PatchDMap k q)
1713+ -> Event x (DMap k v)
1714+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
17011715 where
1702− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1716+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
17031717 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
17041718 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
17051719 (mOldSubd, newPs) <- case me of
17061720 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
17071721 Just e -> do
17081722 let s = subscriber $ return k
1709− subscription@(EventSubscription _ subd) <- subscribe e s
1723+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
17101724 newParentHeight <- liftIO $ getEventSubscribedHeight subd
17111725 let newParent = MergeSubscribedParent subscription
17121726 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1716,28 +1730,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
17161730 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17171731 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
17181732 foldM f ([], oldParents) $ DMap.toList p
1719− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1733+
1734+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
17201735 getInitialSubscribers initialParents subscriber = do
17211736 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17221737 let s = subscriber $ return k
1723− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1738+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17241739 height <- liftIO $ getEventSubscribedHeight parentSubd
1725− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1740+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)
17261741 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17271742 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17281743 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17291744 )
1745+
17301746 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
17311747 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
17321748
17331749{-# INLINE [1] mergeCheapWithMove #-}
1734−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1735−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1750+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1751+ => (forall a. q a -> Event x (v a))
1752+ -> Dynamic x (PatchDMapWithMove k q)
1753+ -> Event x (DMap k v)
1754+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17361755 where
1737− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1756+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
17381757 updateMe subscriber heightBagRef oldParents p = do
17391758 -- Prepare new parents for insertion
1740− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1759+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
17411760 subscribeParent k e = do
17421761 keyRef <- liftIO $ newIORef k
17431762 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1746,9 +1765,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17461765 newParentHeight <- getEventSubscribedHeight subd
17471766 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17481767 return $ MergeSubscribedParentWithMove subscription keyRef
1749− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1768+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
17501769 -- Collect old parents for deletion and update the keys of moved parents
1751− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1770+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17521771 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17531772 Nothing -> do
17541773 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1759,46 +1778,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17591778 return Nothing
17601779 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
17611780 return (toDelete, applyAlways p' oldParents)
1762− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1781+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
17631782 getInitialSubscribers initialParents subscriber = do
17641783 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17651784 keyRef <- liftIO $ newIORef k
17661785 let s = subscriber $ liftIO $ readIORef keyRef
1767− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1786+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17681787 height <- liftIO $ getEventSubscribedHeight parentSubd
1769− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1788+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
17701789 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17711790 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17721791 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17731792 )
1793+
17741794 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
17751795 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
17761796
1777−type MergeUpdateFunc k x p s
1778− = (forall a. EventM x (k a) -> Subscriber x a)
1797+type MergeUpdateFunc k v x p s
1798+ = (forall a. EventM x (k a) -> Subscriber x (v a))
17791799 -> IORef HeightBag
17801800 -> DMap k s
17811801 -> p
17821802 -> EventM x ([EventSubscription x], DMap k s)
17831803
1784−type MergeInitFunc k x s
1785− = DMap k (Event x)
1786− -> (forall a. EventM x (k a) -> Subscriber x a)
1787− -> EventM x (DMap k Identity, [Height], DMap k s)
1804+type MergeInitFunc k v q x s
1805+ = DMap k q
1806+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1807+ -> EventM x (DMap k v, [Height], DMap k s)
17881808
17891809type MergeDestroyFunc k s
17901810 = DMap k s
17911811 -> IO ()
17921812
1793−data Merge x k s = Merge
1813+data Merge x k v s = Merge
17941814 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
17951815 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
17961816 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1797− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1798− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1817+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1818+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
17991819 }
18001820
1801−invalidateMergeHeight :: Merge x k s -> IO ()
1821+invalidateMergeHeight :: Merge x k v s -> IO ()
18021822invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
18031823
18041824invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1808,8 +1828,7 @@ invalidateMergeHeight' heightRef sub = do
18081828 writeIORef heightRef $! invalidHeight
18091829 subscriberInvalidateHeight sub oldHeight
18101830
1811−
1812−revalidateMergeHeight :: Merge x k s -> IO ()
1831+revalidateMergeHeight :: Merge x k v s -> IO ()
18131832revalidateMergeHeight m = do
18141833 currentHeight <- readIORef $ _merge_heightRef m
18151834 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1825,19 +1844,19 @@ revalidateMergeHeight m = do
18251844 subscriberRecalculateHeight (_merge_sub m) height
18261845 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
18271846
1828−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1847+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
18291848scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18301849 vals <- liftIO $ readIORef $ _merge_accumRef m
18311850 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
18321851 --TODO: Assert that m is not empty
18331852 subscriberPropagate (_merge_sub m) vals
18341853
1835−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1854+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
18361855mergeSubscriber m getKey = Subscriber
18371856 { subscriberPropagate = \a -> do
18381857 oldM <- liftIO $ readIORef $ _merge_accumRef m
18391858 k <- getKey
1840− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1859+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
18411860 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
18421861 liftIO $ writeIORef (_merge_accumRef m) $! newM
18431862 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1868,7 +1887,7 @@ mergeSubscriber m getKey = Subscriber
18681887 }
18691888
18701889--TODO: Be able to run as much of this as possible promptly
1871−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1890+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
18721891updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
18731892 where updateMe = do
18741893 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1876,9 +1895,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
18761895 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
18771896 return subscriptionsToKill
18781897
1879−{-# INLINE mergeCheap' #-}
1880−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)
1881−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1898+{-# INLINE mergeGCheap' #-}
1899+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1900+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)
1901+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
18821902 initialParents <- readBehaviorUntracked $ dynamicCurrent d
18831903 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
18841904 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -2461,7 +2481,7 @@ unsafeNewSpiderTimelineEnv = do
24612481newSpiderTimeline :: IO (Some SpiderTimelineEnv)
24622482newSpiderTimeline = withSpiderTimeline (pure . Some)
24632483
2464−data LocalSpiderTimeline x s
2484+data LocalSpiderTimeline (x :: Type) s
24652485
24662486instance Reifies s (SpiderTimelineEnv x) =>
24672487 HasSpiderTimeline (LocalSpiderTimeline x s) where
@@ -2479,11 +2499,11 @@ withSpiderTimeline k = do
24792499 env <- unsafeNewSpiderTimelineEnv
24802500 reify env $ \s -> k $ localSpiderTimeline s env
24812501
2482−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2502+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24832503
24842504type ComputeM = EventM
24852505
2486−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2506+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24872507
24882508instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
24892509 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
@@ -2503,8 +2523,13 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25032523 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
25042524 {-# INLINABLE pull #-}
25052525 pull = SpiderBehavior . pull . coerce
2506− {-# INLINABLE merge #-}
2507− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2526+ {-# INLINABLE mergeG #-}
2527+ mergeG
2528+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2529+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2530+ -> DMap k q
2531+ -> R.Event (SpiderTimeline x) (DMap k v)
2532+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
25082533 {-# INLINABLE fan #-}
25092534 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
25102535 {-# INLINABLE switch #-}
@@ -2519,10 +2544,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25192544 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
25202545 {-# INLINABLE unsafeBuildIncremental #-}
25212546 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2522− {-# INLINABLE mergeIncremental #-}
2523− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2524− {-# INLINABLE mergeIncrementalWithMove #-}
2525− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2547+ {-# INLINABLE mergeIncrementalG #-}
2548+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2549+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2550+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
25262551 {-# INLINABLE currentIncremental #-}
25272552 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
25282553 {-# INLINABLE updatedIncremental #-}
@@ -2560,7 +2585,7 @@ instance MonadAtomicRef (EventM x) where
25602585 atomicModifyRef r f = liftIO $ atomicModifyRef r f
25612586
25622587-- | The monad for actions that manipulate a Spider timeline identified by @x@
2563−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2588+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25642589
25652590instance Monad (SpiderHost x) where
25662591 {-# INLINABLE (>>=) #-}
@@ -2582,7 +2607,7 @@ runSpiderHost (SpiderHost a) = a
25822607runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
25832608runSpiderHostForTimeline (SpiderHost a) _ = a
25842609
2585−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2610+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
25862611 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25872612
25882613instance Monad (SpiderHostFrame x) where
test/GC.hs+2−1
@@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S
2727
2828import System.Exit
2929import System.Mem
30+import Data.Coerce
3031
3132main :: IO ()
3233main = do
@@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do
4647 eventToPerform <- Host.runHostFrame $ do
4748 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
4849 <- S.SpiderHostFrame
49− $ fmap ( S.merge
50+ $ fmap ( S.mergeG coerce
5051 . S.dynamicHold)
5152 $ S.hold DMap.empty
5253 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained