on develop help sign in
Revert "Generalize merge"

This reverts commit 8d8ceecd548f3d4f6e0b8db00a57659511d241a5.

commit13237c376a6199a2487d7c7e9b25c96544ef627c authorMatthew Bauer <mjbauer95@gmail.com> dateFri 31 Jan 2020, 16:57 (7 years ago) parentb3ad64a
5 files changed+72−136
src/Reflex/Class.hs+3−31 src/Reflex/Profiled.hs+5−9 src/Reflex/Pure.hs+10−16 src/Reflex/Spider/Internal.hs+53−78 test/GC.hs+1−2
src/Reflex/Class.hs+3−31
@@ -16,7 +16,6 @@
1616{-# LANGUAGE TypeFamilies #-}
1717{-# LANGUAGE TypeOperators #-}
1818{-# LANGUAGE UndecidableInstances #-}
19−{-# LANGUAGE Trustworthy #-}
2019#ifdef USE_REFLEX_OPTIMIZER
2120{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2221#endif
@@ -46,9 +45,6 @@ module Reflex.Class
4645 , pushAlways
4746 -- ** Combining 'Event's
4847 , leftmost
49− , merge
50− , mergeIncremental
51− , mergeIncrementalWithMove
5248 , mergeMap
5349 , mergeIntMap
5450 , mergeMapIncremental
@@ -269,9 +265,7 @@ class ( MonadHold t (PushM t)
269265 -- | Merge a collection of events; the resulting 'Event' will only occur if at
270266 -- least one input event is occurring, and will contain all of the input keys
271267 -- that are occurring simultaneously
272− mergeG :: GCompare k => (forall a. q a -> Event t (v a))
273− -> DMap k q -> Event t (DMap k v)
274− --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
268+ 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
275269 -- | Efficiently fan-out an event to many destinations. You should save the
276270 -- result in a @let@-binding, and then repeatedly 'select' on the result to
277271 -- create child events
@@ -293,14 +287,9 @@ class ( MonadHold t (PushM t)
293287 -- that value.
294288 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
295289 -- | Create a merge whose parents can change over time
296− mergeIncrementalG :: GCompare k
297− => (forall a. q a -> Event t (v a))
298− -> Incremental t (PatchDMap k q)
299− -> Event t (DMap k v)
290+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
300291 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
301− mergeIncrementalWithMoveG :: GCompare k
302− => (forall a. q a -> Event t (v a))
303− -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
292+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
304293 -- | Extract the 'Behavior' component of an 'Incremental'
305294 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
306295 -- | Extract the 'Event' component of an 'Incremental'
@@ -1576,23 +1565,6 @@ fmapCheap f = pushCheap $ return . Just . f
15761565tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
15771566tagCheap b = pushAlwaysCheap $ \_ -> sample b
15781567
1579−-- | Merge a collection of events; the resulting 'Event' will only occur if at
1580−-- least one input event is occurring, and will contain all of the input keys
1581−-- that are occurring simultaneously
1582−merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
1583−merge = mergeG coerceEvent
1584−{-# INLINE merge #-}
1585−
1586−-- | Create a merge whose parents can change over time
1587−mergeIncremental :: (Reflex t, GCompare k)
1588− => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
1589−mergeIncremental = mergeIncrementalG coerceEvent
1590−
1591−-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
1592−mergeIncrementalWithMove :: (Reflex t, GCompare k)
1593− => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
1594−mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent
1595−
15961568-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
15971569{-# INLINE mergeWithCheap #-}
15981570mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
src/Reflex/Profiled.hs+5−9
@@ -8,8 +8,6 @@
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeFamilies #-}
1010{-# LANGUAGE UndecidableInstances #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE RankNTypes #-}
1311-- |
1412-- Module:
1513-- Reflex.Profiled
@@ -18,6 +16,7 @@
1816-- profiling/cost-center information.
1917module Reflex.Profiled where
2018
19+import Control.Lens hiding (children)
2120import Control.Monad
2221import Control.Monad.Exception
2322import Control.Monad.Fix
@@ -34,7 +33,6 @@ import Data.Map (Map)
3433import qualified Data.Map.Strict as Map
3534import Data.Monoid ((<>))
3635import Data.Ord
37−import Data.Profunctor.Unsafe ((#.))
3836import qualified Data.Semigroup as S
3937import Data.Type.Coercion
4038import Foreign.Ptr
@@ -135,10 +133,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
135133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
136134 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
137135 pull = Behavior_Profiled . pull . coerce
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)
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))
142138 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
143139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
144140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
@@ -146,8 +142,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
146142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
147143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
148144 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
149− mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
150− mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
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)))
151147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
152148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
153149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
src/Reflex/Pure.hs+10−16
@@ -5,8 +5,6 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE ScopedTypeVariables #-}
77{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE PolyKinds #-}
108#ifdef USE_REFLEX_OPTIMIZER
119{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1210#endif
@@ -41,11 +39,10 @@ import Data.MemoTrie
4139import Data.Monoid
4240import Data.Type.Coercion
4341import Reflex.Class
44−import Data.Kind (Type)
4542
4643-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
4744-- with the type @/t/@.
48−data Pure (t :: Type)
45+data Pure t
4946
5047-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
5148-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
@@ -78,12 +75,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
7875 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
7976 -- warning because the GCompare instance is not used; however, removing the
8077 -- GCompare instance produces a different warning, due to that constraint
81− -- being present in the original class definition.
78+ -- being present in the original class definition
8279
83− --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
84− -- -> DMap k q -> Event (Pure t) (DMap k v)
85− mergeG nt events = Event $ memo $ \t ->
86− let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
80+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
81+ merge events = Event $ memo $ \t ->
82+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
8783 in if DMap.null currentOccurrences
8884 then Nothing
8985 else Just currentOccurrences
@@ -112,8 +108,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
112108 --a) -> Incremental (Pure t) p a
113109 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
114110
115− mergeIncrementalG = mergeIncrementalImpl
116− mergeIncrementalWithMoveG = mergeIncrementalImpl
111+ mergeIncremental = mergeIncrementalImpl
112+ mergeIncrementalWithMove = mergeIncrementalImpl
117113
118114 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
119115
@@ -133,11 +129,9 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
133129
134130 mergeIntIncremental = mergeIntIncrementalImpl
135131
136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
137− => (forall a. q a -> Event (Pure t) (v a))
138− -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
139−mergeIncrementalImpl nt i = Event $ \t ->
140− let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
132+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
133+mergeIncrementalImpl i = Event $ \t ->
134+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
141135 in if DMap.null results
142136 then Nothing
143137 else Just results
src/Reflex/Spider/Internal.hs+53−78
@@ -16,12 +16,9 @@
1616{-# LANGUAGE TypeFamilies #-}
1717{-# LANGUAGE TypeOperators #-}
1818{-# LANGUAGE UndecidableInstances #-}
19−{-# LANGUAGE PolyKinds #-}
20−{-# LANGUAGE InstanceSigs #-}
2119#ifdef USE_REFLEX_OPTIMIZER
2220{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2321#endif
24−{-# OPTIONS_GHC -Wunused-binds #-}
2522-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2623-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2724module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -51,7 +48,6 @@ import Data.GADT.Compare
5148import Data.IntMap.Strict (IntMap)
5249import qualified Data.IntMap.Strict as IntMap
5350import Data.IORef
54−import Data.Kind (Type)
5551import Data.Maybe hiding (mapMaybe)
5652import Data.Monoid ((<>))
5753import Data.Proxy
@@ -88,7 +84,6 @@ import qualified Data.FastWeakBag as FastWeakBag
8884import Data.Reflection
8985import Data.Some (Some(Some))
9086import Data.Type.Coercion
91−import Data.Profunctor.Unsafe ((#.), (.#))
9287import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
9388import qualified Data.WeakBag as WeakBag
9489import qualified Reflex.Class
@@ -1148,8 +1143,7 @@ instance HasSpiderTimeline x => Align (Event x) where
11481143#if MIN_VERSION_these(0, 8, 0)
11491144instance HasSpiderTimeline x => Semialign (Event x) where
11501145#endif
1151− align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1152− DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1146+ align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
11531147
11541148#ifdef MIN_VERSION_semialign
11551149#if MIN_VERSION_semialign(1,1,0)
@@ -1162,7 +1156,7 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
11621156 | BuildDyn !(EventM x (PatchTarget p), Event x p)
11631157 | HoldDyn !(Hold x p)
11641158
1165−newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1159+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
11661160
11671161newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
11681162newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
@@ -1708,34 +1702,26 @@ cleanupCoincidenceSubscribed subscribed = do
17081702subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
17091703subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
17101704
1711−{-# INLINE mergeG #-}
1712−mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1713− => (forall a. q a -> Event x (v a))
1714− -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)
1715−mergeG nt d = cacheEvent (mergeCheap nt d)
1705+{-# INLINE merge #-}
1706+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1707+merge d = cacheEvent (mergeCheap d)
17161708
17171709{-# INLINE mergeWithMove #-}
1718−mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1719− => (forall a. q a -> Event x (v a))
1720− -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)
1721−mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1710+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1711+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
17221712
17231713{-# INLINE [1] mergeCheap #-}
1724−mergeCheap
1725− :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1726− => (forall a. q a -> Event x (v a))
1727− -> Dynamic x (PatchDMap k q)
1728− -> Event x (DMap k v)
1729−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1714+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1715+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
17301716 where
1731− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1717+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
17321718 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
17331719 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
17341720 (mOldSubd, newPs) <- case me of
17351721 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
17361722 Just e -> do
17371723 let s = subscriber $ return k
1738− subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1724+ subscription@(EventSubscription _ subd) <- subscribe e s
17391725 newParentHeight <- liftIO $ getEventSubscribedHeight subd
17401726 let newParent = MergeSubscribedParent subscription
17411727 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1745,33 +1731,28 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
17451731 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17461732 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
17471733 foldM f ([], oldParents) $ DMap.toList p
1748−
1749− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1734+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
17501735 getInitialSubscribers initialParents subscriber = do
17511736 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17521737 let s = subscriber $ return k
1753− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1738+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
17541739 height <- liftIO $ getEventSubscribedHeight parentSubd
1755− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1740+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
17561741 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17571742 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17581743 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17591744 )
1760−
17611745 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
17621746 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
17631747
17641748{-# INLINE [1] mergeCheapWithMove #-}
1765−mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1766− => (forall a. q a -> Event x (v a))
1767− -> Dynamic x (PatchDMapWithMove k q)
1768− -> Event x (DMap k v)
1769−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1749+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1750+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17701751 where
1771− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1752+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
17721753 updateMe subscriber heightBagRef oldParents p = do
17731754 -- Prepare new parents for insertion
1774− let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1755+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
17751756 subscribeParent k e = do
17761757 keyRef <- liftIO $ newIORef k
17771758 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1780,9 +1761,9 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17801761 newParentHeight <- getEventSubscribedHeight subd
17811762 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17821763 return $ MergeSubscribedParentWithMove subscription keyRef
1783− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1764+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
17841765 -- Collect old parents for deletion and update the keys of moved parents
1785− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1766+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17861767 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17871768 Nothing -> do
17881769 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1793,47 +1774,46 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17931774 return Nothing
17941775 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
17951776 return (toDelete, applyAlways p' oldParents)
1796− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1777+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
17971778 getInitialSubscribers initialParents subscriber = do
17981779 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17991780 keyRef <- liftIO $ newIORef k
18001781 let s = subscriber $ liftIO $ readIORef keyRef
1801− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1782+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
18021783 height <- liftIO $ getEventSubscribedHeight parentSubd
1803− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1784+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
18041785 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
18051786 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
18061787 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
18071788 )
1808−
18091789 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
18101790 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
18111791
1812−type MergeUpdateFunc k v x p s
1813− = (forall a. EventM x (k a) -> Subscriber x (v a))
1792+type MergeUpdateFunc k x p s
1793+ = (forall a. EventM x (k a) -> Subscriber x a)
18141794 -> IORef HeightBag
18151795 -> DMap k s
18161796 -> p
18171797 -> EventM x ([EventSubscription x], DMap k s)
18181798
1819−type MergeInitFunc k v q x s
1820− = DMap k q
1821− -> (forall a. EventM x (k a) -> Subscriber x (v a))
1822− -> EventM x (DMap k v, [Height], DMap k s)
1799+type MergeInitFunc k x s
1800+ = DMap k (Event x)
1801+ -> (forall a. EventM x (k a) -> Subscriber x a)
1802+ -> EventM x (DMap k Identity, [Height], DMap k s)
18231803
18241804type MergeDestroyFunc k s
18251805 = DMap k s
18261806 -> IO ()
18271807
1828−data Merge x k v s = Merge
1808+data Merge x k s = Merge
18291809 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
18301810 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
18311811 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1832− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1833− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1812+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1813+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
18341814 }
18351815
1836−invalidateMergeHeight :: Merge x k v s -> IO ()
1816+invalidateMergeHeight :: Merge x k s -> IO ()
18371817invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
18381818
18391819invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1843,7 +1823,8 @@ invalidateMergeHeight' heightRef sub = do
18431823 writeIORef heightRef $! invalidHeight
18441824 subscriberInvalidateHeight sub oldHeight
18451825
1846−revalidateMergeHeight :: Merge x k v s -> IO ()
1826+
1827+revalidateMergeHeight :: Merge x k s -> IO ()
18471828revalidateMergeHeight m = do
18481829 currentHeight <- readIORef $ _merge_heightRef m
18491830 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1859,19 +1840,19 @@ revalidateMergeHeight m = do
18591840 subscriberRecalculateHeight (_merge_sub m) height
18601841 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
18611842
1862−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1843+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
18631844scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18641845 vals <- liftIO $ readIORef $ _merge_accumRef m
18651846 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
18661847 --TODO: Assert that m is not empty
18671848 subscriberPropagate (_merge_sub m) vals
18681849
1869−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1850+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
18701851mergeSubscriber m getKey = Subscriber
18711852 { subscriberPropagate = \a -> do
18721853 oldM <- liftIO $ readIORef $ _merge_accumRef m
18731854 k <- getKey
1874− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1855+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
18751856 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
18761857 liftIO $ writeIORef (_merge_accumRef m) $! newM
18771858 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1902,7 +1883,7 @@ mergeSubscriber m getKey = Subscriber
19021883 }
19031884
19041885--TODO: Be able to run as much of this as possible promptly
1905−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1886+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
19061887updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
19071888 where updateMe = do
19081889 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1910,10 +1891,9 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
19101891 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
19111892 return subscriptionsToKill
19121893
1913−{-# INLINE mergeGCheap' #-}
1914−mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1915− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)
1916−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1894+{-# INLINE mergeCheap' #-}
1895+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)
1896+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
19171897 initialParents <- readBehaviorUntracked $ dynamicCurrent d
19181898 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
19191899 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -2496,7 +2476,7 @@ unsafeNewSpiderTimelineEnv = do
24962476newSpiderTimeline :: IO (Some SpiderTimelineEnv)
24972477newSpiderTimeline = withSpiderTimeline (pure . Some)
24982478
2499−data LocalSpiderTimeline (x :: Type) s
2479+data LocalSpiderTimeline x s
25002480
25012481instance Reifies s (SpiderTimelineEnv x) =>
25022482 HasSpiderTimeline (LocalSpiderTimeline x s) where
@@ -2514,11 +2494,11 @@ withSpiderTimeline k = do
25142494 env <- unsafeNewSpiderTimelineEnv
25152495 reify env $ \s -> k $ localSpiderTimeline s env
25162496
2517−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2497+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
25182498
25192499type ComputeM = EventM
25202500
2521−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2501+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
25222502
25232503instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25242504 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
@@ -2538,13 +2518,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25382518 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
25392519 {-# INLINABLE pull #-}
25402520 pull = SpiderBehavior . pull . coerce
2541− {-# INLINABLE mergeG #-}
2542− mergeG
2543− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2544− => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2545− -> DMap k q
2546− -> R.Event (SpiderTimeline x) (DMap k v)
2547− mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2521+ {-# INLINABLE merge #-}
2522+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
25482523 {-# INLINABLE fan #-}
25492524 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
25502525 {-# INLINABLE switch #-}
@@ -2559,10 +2534,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25592534 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
25602535 {-# INLINABLE unsafeBuildIncremental #-}
25612536 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2562− {-# INLINABLE mergeIncrementalG #-}
2563− mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2564− {-# INLINABLE mergeIncrementalWithMoveG #-}
2565− mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2537+ {-# INLINABLE mergeIncremental #-}
2538+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2539+ {-# INLINABLE mergeIncrementalWithMove #-}
2540+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
25662541 {-# INLINABLE currentIncremental #-}
25672542 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
25682543 {-# INLINABLE updatedIncremental #-}
@@ -2600,7 +2575,7 @@ instance MonadAtomicRef (EventM x) where
26002575 atomicModifyRef r f = liftIO $ atomicModifyRef r f
26012576
26022577-- | The monad for actions that manipulate a Spider timeline identified by @x@
2603−newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2578+newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
26042579
26052580instance Monad (SpiderHost x) where
26062581 {-# INLINABLE (>>=) #-}
@@ -2622,7 +2597,7 @@ runSpiderHost (SpiderHost a) = a
26222597runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
26232598runSpiderHostForTimeline (SpiderHost a) _ = a
26242599
2625−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2600+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
26262601 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
26272602
26282603instance Monad (SpiderHostFrame x) where
test/GC.hs+1−2
@@ -27,7 +27,6 @@ import qualified Reflex.Spider.Internal as S
2727
2828import System.Exit
2929import System.Mem
30−import Data.Coerce
3130
3231main :: IO ()
3332main = do
@@ -47,7 +46,7 @@ hostPerf ref = S.runSpiderHost $ do
4746 eventToPerform <- Host.runHostFrame $ do
4847 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
4948 <- S.SpiderHostFrame
50− $ fmap ( S.mergeG coerce
49+ $ fmap ( S.merge
5150 . S.dynamicHold)
5251 $ S.hold DMap.empty
5352 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained