@@ -17,9 +17,13 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE InstanceSigs #-}
22+
2023#ifdef USE_REFLEX_OPTIMIZER
2124{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2225#endif
26+{-# OPTIONS_GHC -Wunused-binds #-}
2327-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2428-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2529module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -49,6 +53,7 @@ import Data.GADT.Compare
4953import Data.IntMap.Strict (IntMap)
5054import qualified Data.IntMap.Strict as IntMap
5155import Data.IORef
56+import Data.Kind (Type)
5257import Data.Maybe hiding (mapMaybe)
5358import Data.Monoid ((<>))
5459import Data.Proxy
@@ -74,9 +79,9 @@ import Data.Tree (Forest, Tree (..), drawForest)
7479import Data.FastWeakBag (FastWeakBag)
7580import qualified Data.FastWeakBag as FastWeakBag
7681import Data.Reflection
77−import Data.Some (Some)
78−import qualified Data.Some as Some
82+import Data.Some (Some(Some))
7983import Data.Type.Coercion
84+import Data.Profunctor.Unsafe ((#.), (.#))
8085import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
8186import qualified Data.WeakBag as WeakBag
8287import qualified Reflex.Class
@@ -193,12 +198,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
193198
194199newNodeId :: IO Int
195200newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
196−
197−{-# NOINLINE unsafeNodeId #-}
198−unsafeNodeId :: a -> Int
199−unsafeNodeId a = unsafePerformIO $ do
200− touch a
201− newNodeId
202201#endif
203202
204203--------------------------------------------------------------------------------
@@ -302,9 +301,10 @@ cacheEvent e =
302301#else
303302 Event $
304303#endif
305− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
307− in \sub -> {-# SCC "cacheEvent" #-} do
304+ unsafePerformIO $ do
305+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306+ <- newIORef emptyFastWeak
307+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
308308#ifdef DEBUG_TRACE_EVENTS
309309 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
310310#endif
@@ -370,7 +370,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
370370eventNever :: Event x a
371371eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
372372
373−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
373+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
374374eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
375375
376376eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -422,14 +422,14 @@ newSubscriberHold h = return $ Subscriber
422422 , subscriberRecalculateHeight = \_ -> return ()
423423 }
424424
425−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
425+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
426426newSubscriberFan subscribed = return $ Subscriber
427427 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
428428 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
429429 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
430430 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
431431 scheduleClear $ fanSubscribedOccurrence subscribed
432− let f _ (Pair (Identity v) subsubs) = do
432+ let f _ (Pair v subsubs) = do
433433 propagate v $ _fanSubscribedChildren_list subsubs
434434 return $ Constant ()
435435 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -577,12 +577,12 @@ eventSubscribedNever = EventSubscribed
577577#endif
578578 }
579579
580−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
580+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
581581eventSubscribedFan !subscribed = EventSubscribed
582582 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
583583 , eventSubscribedRetained = toAny subscribed
584584#ifdef DEBUG_CYCLES
585− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
585+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
586586 , eventSubscribedHasOwnHeightRef = False
587587 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
588588#endif
@@ -595,7 +595,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
595595#ifdef DEBUG_CYCLES
596596 , eventSubscribedGetParents = do
597597 s <- readIORef $ switchSubscribedCurrentParent subscribed
598− return [Some.This $ _eventSubscription_subscribed s]
598+ return [Some $ _eventSubscription_subscribed s]
599599 , eventSubscribedHasOwnHeightRef = True
600600 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
601601#endif
@@ -608,8 +608,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
608608#ifdef DEBUG_CYCLES
609609 , eventSubscribedGetParents = do
610610 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
611− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612− innerParents = maybeToList $ fmap Some.This innerSubscription
611+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612+ innerParents = maybeToList $ fmap Some innerSubscription
613613 return $ outerParent : innerParents
614614 , eventSubscribedHasOwnHeightRef = True
615615 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -625,13 +625,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated
625625
626626walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
627627walkInvalidHeightParents s0 = do
628− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
628+ subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
629629 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
630630 when (h == invalidHeight) $ do
631631 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
632− modify (Some.This s :)
632+ modify (Some s :)
633633 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
634− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
634+ forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
635635 return subscribers
636636#endif
637637
@@ -659,7 +659,7 @@ behaviorPull !p = Behavior $ do
659659 val <- liftIO $ readIORef $ pullValue p
660660 case val of
661661 Just subscribed -> do
662− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
662+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
663663 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
664664 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
665665 return $ pullSubscribedValue subscribed
@@ -678,7 +678,7 @@ behaviorPull !p = Behavior $ do
678678 , pullSubscribedParents = parents
679679 }
680680 liftIO $ writeIORef (pullValue p) $ Just subscribed
681− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
681+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
682682 return a
683683
684684behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
@@ -689,7 +689,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
689689readHoldTracked h = do
690690 result <- liftIO $ readIORef $ holdValue h
691691 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
692− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
692+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
693693 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
694694 return result
695695
@@ -705,7 +705,7 @@ readBehaviorUntracked b = do
705705
706706data Dynamic x p = Dynamic
707707 { dynamicCurrent :: !(Behavior x (PatchTarget p))
708− , dynamicUpdated :: !(Event x p)
708+ , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
709709 }
710710
711711dynamicHold :: Hold x p -> Dynamic x p
@@ -782,9 +782,9 @@ data EventEnv x
782782 , eventEnvDynInits :: !(IORef [SomeDynInit x])
783783 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
784784 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
785− , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
786− , eventEnvIntClears :: !(IORef [SomeIntClear])
787− , eventEnvRootClears :: !(IORef [SomeRootClear])
785+ , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe
786+ , eventEnvIntClears :: !(IORef [Some IntClear])
787+ , eventEnvRootClears :: !(IORef [Some RootClear])
788788 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
789789 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
790790 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
@@ -856,29 +856,29 @@ putCurrentHeight h = do
856856 heightRef <- asksEventEnv eventEnvCurrentHeight
857857 liftIO $ writeIORef heightRef $! h
858858
859−instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
859+instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
860860 {-# INLINE getDeferralQueue #-}
861861 getDeferralQueue = asksEventEnv eventEnvClears
862862
863863{-# INLINE scheduleClear #-}
864−scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
865−scheduleClear r = defer $ SomeClear r
864+scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
865+scheduleClear r = defer $ Some $ Clear r
866866
867−instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
867+instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
868868 {-# INLINE getDeferralQueue #-}
869869 getDeferralQueue = asksEventEnv eventEnvIntClears
870870
871871{-# INLINE scheduleIntClear #-}
872−scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
873−scheduleIntClear r = defer $ SomeIntClear r
872+scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
873+scheduleIntClear r = defer $ Some $ IntClear r
874874
875−instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
875+instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
876876 {-# INLINE getDeferralQueue #-}
877877 getDeferralQueue = asksEventEnv eventEnvRootClears
878878
879879{-# INLINE scheduleRootClear #-}
880−scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
881−scheduleRootClear r = defer $ SomeRootClear r
880+scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
881+scheduleRootClear r = defer $ Some $ RootClear r
882882
883883instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
884884 {-# INLINE getDeferralQueue #-}
@@ -951,7 +951,7 @@ data BehaviorSubscribed x a
951951 = forall p. BehaviorSubscribedHold (Hold x p)
952952 | BehaviorSubscribedPull (PullSubscribed x a)
953953
954−data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
954+newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))
955955
956956--type role PullSubscribed representational
957957data PullSubscribed x a
@@ -986,7 +986,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
986986#endif
987987 }
988988
989−data Root x (k :: * -> *)
989+data Root x k
990990 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
991991 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
992992 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1056,25 +1056,25 @@ heightBagVerify b@(HeightBag s c) = if
10561056heightBagVerify = id
10571057#endif
10581058
1059−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1060− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1061− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1062− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1059+data FanSubscribedChildren x k v a = FanSubscribedChildren
1060+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1061+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1062+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
10631063 }
10641064
1065−data FanSubscribed (x :: *) k
1066− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1067− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1068− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1065+data FanSubscribed x k v
1066+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1067+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1068+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
10691069 , fanSubscribedParent :: !(EventSubscription x)
10701070#ifdef DEBUG_NODEIDS
10711071 , fanSubscribedNodeId :: Int
10721072#endif
10731073 }
10741074
1075−data Fan x k
1076− = Fan { fanParent :: !(Event x (DMap k Identity))
1077− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1075+data Fan x k v
1076+ = Fan { fanParent :: !(Event x (DMap k v))
1077+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
10781078 }
10791079
10801080data SwitchSubscribed x a
@@ -1133,13 +1133,17 @@ instance HasSpiderTimeline x => Filterable (Event x) where
11331133
11341134instance HasSpiderTimeline x => Align (Event x) where
11351135 nil = eventNever
1136− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1136+#if MIN_VERSION_these(0, 8, 0)
1137+instance HasSpiderTimeline x => Semialign (Event x) where
1138+#endif
1139+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1140+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
11371141
11381142data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
11391143 | BuildDyn !(EventM x (PatchTarget p), Event x p)
11401144 | HoldDyn !(Hold x p)
11411145
1142−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1146+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
11431147
11441148newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
11451149newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
@@ -1168,18 +1172,12 @@ buildDynamic readV0 v' = do
11681172 return d
11691173
11701174unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1171−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1172− where x = (readV0, v')
1175+unsafeBuildDynamic readV0 v' =
1176+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
11731177
11741178-- ResultM can read behaviors and events
11751179type ResultM = EventM
11761180
1177−{-# NOINLINE unsafeNewIORef #-}
1178−unsafeNewIORef :: a -> b -> IORef b
1179−unsafeNewIORef a b = unsafePerformIO $ do
1180− touch a
1181− newIORef b
1182−
11831181instance HasSpiderTimeline x => Functor (Event x) where
11841182 fmap f = push $ return . Just . f
11851183
@@ -1192,26 +1190,35 @@ push f e = cacheEvent (pushCheap f e)
11921190
11931191{-# INLINABLE pull #-}
11941192pull :: BehaviorM x a -> Behavior x a
1195−pull a = behaviorPull $ Pull
1196− { pullCompute = a
1197− , pullValue = unsafeNewIORef a Nothing
1193+pull a = unsafePerformIO $ do
1194+ ref <- newIORef Nothing
11981195#ifdef DEBUG_NODEIDS
1199− , pullNodeId = unsafeNodeId a
1196+ nid <- newNodeId
12001197#endif
1201− }
1198+ pure $ behaviorPull $ Pull
1199+ { pullCompute = a
1200+ , pullValue = ref
1201+#ifdef DEBUG_NODEIDS
1202+ , pullNodeId = nid
1203+#endif
1204+ }
12021205
12031206{-# INLINABLE switch #-}
12041207switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1205−switch a = eventSwitch $ Switch
1206− { switchParent = a
1207− , switchSubscribed = unsafeNewIORef a Nothing
1208− }
1208+switch a = unsafePerformIO $ do
1209+ ref <- newIORef Nothing
1210+ pure $ eventSwitch $ Switch
1211+ { switchParent = a
1212+ , switchSubscribed = ref
1213+ }
12091214
12101215coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1211−coincidence a = eventCoincidence $ Coincidence
1212− { coincidenceParent = a
1213− , coincidenceSubscribed = unsafeNewIORef a Nothing
1214− }
1216+coincidence a = unsafePerformIO $ do
1217+ ref <- newIORef Nothing
1218+ pure $ eventCoincidence $ Coincidence
1219+ { coincidenceParent = a
1220+ , coincidenceSubscribed = ref
1221+ }
12151222
12161223-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
12171224run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
@@ -1256,11 +1263,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
12561263 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
12571264 EQ -> a
12581265
1259−data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1266+newtype Clear a = Clear (IORef (Maybe a))
12601267
1261−data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1268+newtype IntClear a = IntClear (IORef (IntMap a))
12621269
1263−data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1270+newtype RootClear k = RootClear (IORef (DMap k Identity))
12641271
12651272data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
12661273
@@ -1415,6 +1422,9 @@ getRootSubscribed k r sub = do
14151422 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
14161423 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
14171424 writeIORef uninitRef $! uninit
1425+#ifdef DEBUG_NODEIDS
1426+ nid <- newNodeId
1427+#endif
14181428 let !subscribed = RootSubscribed
14191429 { rootSubscribedKey = k
14201430 , rootSubscribedCachedSubscribed = cached
@@ -1423,7 +1433,7 @@ getRootSubscribed k r sub = do
14231433 , rootSubscribedUninit = uninit
14241434 , rootSubscribedWeakSelf = weakSelf
14251435#ifdef DEBUG_NODEIDS
1426− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1436+ , rootSubscribedNodeId = nid
14271437#endif
14281438 }
14291439 -- If we die at the same moment that all our children die, they will
@@ -1472,16 +1482,10 @@ newFanInt = do
14721482 , _fanInt_occRef = occRef
14731483 }
14741484
1475−{-# NOINLINE unsafeNewFanInt #-}
1476−unsafeNewFanInt :: b -> FanInt x a
1477−unsafeNewFanInt b = unsafePerformIO $ do
1478− touch b
1479− newFanInt
1480−
14811485fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1482−fanInt p =
1483− let self = unsafeNewFanInt p
1484− in EventSelectorInt $ \k -> Event $ \sub -> do
1486+fanInt p = unsafePerformIO $ do
1487+ self <- newFanInt
1488+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
14851489 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
14861490 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
14871491 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1517,7 +1521,7 @@ fanInt p =
15171521 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
15181522
15191523{-# INLINABLE getFanSubscribed #-}
1520−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1524+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
15211525getFanSubscribed k f sub = do
15221526 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
15231527 case mSubscribed of
@@ -1535,13 +1539,16 @@ getFanSubscribed k f sub = do
15351539 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
15361540 occRef <- liftIO $ newIORef parentOcc
15371541 when (isJust parentOcc) $ scheduleClear occRef
1542+#ifdef DEBUG_NODEIDS
1543+ nid <- liftIO newNodeId
1544+#endif
15381545 let subscribed = FanSubscribed
15391546 { fanSubscribedCachedSubscribed = fanSubscribed f
15401547 , fanSubscribedOccurrence = occRef
15411548 , fanSubscribedParent = subscription
15421549 , fanSubscribedSubscribers = subscribersRef
15431550#ifdef DEBUG_NODEIDS
1544− , fanSubscribedNodeId = unsafeNodeId f
1551+ , fanSubscribedNodeId = nid
15451552#endif
15461553 }
15471554 let !self = (k, subscribed)
@@ -1551,7 +1558,7 @@ getFanSubscribed k f sub = do
15511558 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
15521559 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
15531560
1554−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1561+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
15551562cleanupFanSubscribed (k, subscribed) = do
15561563 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15571564 let reducedSubscribers = DMap.delete k subscribers
@@ -1563,7 +1570,7 @@ cleanupFanSubscribed (k, subscribed) = do
15631570 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
15641571
15651572{-# INLINE subscribeFanSubscribed #-}
1566−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1573+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
15671574subscribeFanSubscribed k subscribed sub = do
15681575 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15691576 case DMap.lookup k subscribers of
@@ -1601,6 +1608,9 @@ getSwitchSubscribed s sub = do
16011608 when (isJust parentOcc) $ scheduleClear occRef
16021609 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
16031610 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1611+#ifdef DEBUG_NODEIDS
1612+ nid <- liftIO newNodeId
1613+#endif
16041614 let !subscribed = SwitchSubscribed
16051615 { switchSubscribedCachedSubscribed = switchSubscribed s
16061616 , switchSubscribedOccurrence = occRef
@@ -1613,7 +1623,7 @@ getSwitchSubscribed s sub = do
16131623 , switchSubscribedCurrentParent = subscriptionRef
16141624 , switchSubscribedWeakSelf = weakSelf
16151625#ifdef DEBUG_NODEIDS
1616− , switchSubscribedNodeId = unsafeNodeId s
1626+ , switchSubscribedNodeId = nid
16171627#endif
16181628 }
16191629 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1658,6 +1668,9 @@ getCoincidenceSubscribed c sub = do
16581668 scheduleClear innerSubdRef
16591669 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
16601670 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1671+#ifdef DEBUG_NODEIDS
1672+ nid <- liftIO newNodeId
1673+#endif
16611674 let subscribed = CoincidenceSubscribed
16621675 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
16631676 , coincidenceSubscribedOccurrence = occRef
@@ -1668,7 +1681,7 @@ getCoincidenceSubscribed c sub = do
16681681 , coincidenceSubscribedInnerParent = innerSubdRef
16691682 , coincidenceSubscribedWeakSelf = weakSelf
16701683#ifdef DEBUG_NODEIDS
1671− , coincidenceSubscribedNodeId = unsafeNodeId c
1684+ , coincidenceSubscribedNodeId = nid
16721685#endif
16731686 }
16741687 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1685,26 +1698,34 @@ cleanupCoincidenceSubscribed subscribed = do
16851698subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
16861699subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
16871700
1688−{-# INLINE merge #-}
1689−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1690−merge d = cacheEvent (mergeCheap d)
1701+{-# INLINE mergeG #-}
1702+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1703+ => (forall a. q a -> Event x (v a))
1704+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)
1705+mergeG nt d = cacheEvent (mergeCheap nt d)
16911706
16921707{-# INLINE mergeWithMove #-}
1693−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1694−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1708+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1709+ => (forall a. q a -> Event x (v a))
1710+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)
1711+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
16951712
16961713{-# INLINE [1] mergeCheap #-}
1697−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1698−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1714+mergeCheap
1715+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1716+ => (forall a. q a -> Event x (v a))
1717+ -> Dynamic x (PatchDMap k q)
1718+ -> Event x (DMap k v)
1719+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
16991720 where
1700− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1721+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
17011722 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
17021723 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
17031724 (mOldSubd, newPs) <- case me of
17041725 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
17051726 Just e -> do
17061727 let s = subscriber $ return k
1707− subscription@(EventSubscription _ subd) <- subscribe e s
1728+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
17081729 newParentHeight <- liftIO $ getEventSubscribedHeight subd
17091730 let newParent = MergeSubscribedParent subscription
17101731 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1714,28 +1735,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
17141735 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17151736 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
17161737 foldM f ([], oldParents) $ DMap.toList p
1717− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1738+
1739+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
17181740 getInitialSubscribers initialParents subscriber = do
17191741 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17201742 let s = subscriber $ return k
1721− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1743+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17221744 height <- liftIO $ getEventSubscribedHeight parentSubd
1723− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1745+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)
17241746 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17251747 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17261748 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17271749 )
1750+
17281751 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
17291752 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
17301753
17311754{-# INLINE [1] mergeCheapWithMove #-}
1732−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1733−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1755+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1756+ => (forall a. q a -> Event x (v a))
1757+ -> Dynamic x (PatchDMapWithMove k q)
1758+ -> Event x (DMap k v)
1759+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17341760 where
1735− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1761+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
17361762 updateMe subscriber heightBagRef oldParents p = do
17371763 -- Prepare new parents for insertion
1738− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1764+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
17391765 subscribeParent k e = do
17401766 keyRef <- liftIO $ newIORef k
17411767 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1744,9 +1770,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17441770 newParentHeight <- getEventSubscribedHeight subd
17451771 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17461772 return $ MergeSubscribedParentWithMove subscription keyRef
1747− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1773+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
17481774 -- Collect old parents for deletion and update the keys of moved parents
1749− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1775+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17501776 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17511777 Nothing -> do
17521778 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1757,46 +1783,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17571783 return Nothing
17581784 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
17591785 return (toDelete, applyAlways p' oldParents)
1760− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1786+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
17611787 getInitialSubscribers initialParents subscriber = do
17621788 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17631789 keyRef <- liftIO $ newIORef k
17641790 let s = subscriber $ liftIO $ readIORef keyRef
1765− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1791+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17661792 height <- liftIO $ getEventSubscribedHeight parentSubd
1767− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1793+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
17681794 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17691795 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17701796 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17711797 )
1798+
17721799 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
17731800 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
17741801
1775−type MergeUpdateFunc k x p s
1776− = (forall a. EventM x (k a) -> Subscriber x a)
1802+type MergeUpdateFunc k v x p s
1803+ = (forall a. EventM x (k a) -> Subscriber x (v a))
17771804 -> IORef HeightBag
17781805 -> DMap k s
17791806 -> p
17801807 -> EventM x ([EventSubscription x], DMap k s)
17811808
1782−type MergeInitFunc k x s
1783− = DMap k (Event x)
1784− -> (forall a. EventM x (k a) -> Subscriber x a)
1785− -> EventM x (DMap k Identity, [Height], DMap k s)
1809+type MergeInitFunc k v q x s
1810+ = DMap k q
1811+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1812+ -> EventM x (DMap k v, [Height], DMap k s)
17861813
17871814type MergeDestroyFunc k s
17881815 = DMap k s
17891816 -> IO ()
17901817
1791−data Merge x k s = Merge
1818+data Merge x k v s = Merge
17921819 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
17931820 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
17941821 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1795− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1796− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1822+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1823+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
17971824 }
17981825
1799−invalidateMergeHeight :: Merge x k s -> IO ()
1826+invalidateMergeHeight :: Merge x k v s -> IO ()
18001827invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
18011828
18021829invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1806,8 +1833,7 @@ invalidateMergeHeight' heightRef sub = do
18061833 writeIORef heightRef $! invalidHeight
18071834 subscriberInvalidateHeight sub oldHeight
18081835
1809−
1810−revalidateMergeHeight :: Merge x k s -> IO ()
1836+revalidateMergeHeight :: Merge x k v s -> IO ()
18111837revalidateMergeHeight m = do
18121838 currentHeight <- readIORef $ _merge_heightRef m
18131839 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1823,19 +1849,19 @@ revalidateMergeHeight m = do
18231849 subscriberRecalculateHeight (_merge_sub m) height
18241850 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
18251851
1826−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1852+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
18271853scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18281854 vals <- liftIO $ readIORef $ _merge_accumRef m
18291855 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
18301856 --TODO: Assert that m is not empty
18311857 subscriberPropagate (_merge_sub m) vals
18321858
1833−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1859+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
18341860mergeSubscriber m getKey = Subscriber
18351861 { subscriberPropagate = \a -> do
18361862 oldM <- liftIO $ readIORef $ _merge_accumRef m
18371863 k <- getKey
1838− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1864+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
18391865 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
18401866 liftIO $ writeIORef (_merge_accumRef m) $! newM
18411867 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1850,7 +1876,7 @@ mergeSubscriber m getKey = Subscriber
18501876 else liftIO $ do
18511877#ifdef DEBUG_CYCLES
18521878 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1853− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1879+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
18541880 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
18551881#else
18561882 let cycleInfo = ""
@@ -1866,7 +1892,7 @@ mergeSubscriber m getKey = Subscriber
18661892 }
18671893
18681894--TODO: Be able to run as much of this as possible promptly
1869−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1895+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
18701896updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
18711897 where updateMe = do
18721898 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1874,9 +1900,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
18741900 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
18751901 return subscriptionsToKill
18761902
1877−{-# INLINE mergeCheap' #-}
1878−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)
1879−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1903+{-# INLINE mergeGCheap' #-}
1904+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1905+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)
1906+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
18801907 initialParents <- readBehaviorUntracked $ dynamicCurrent d
18811908 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
18821909 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -2025,14 +2052,16 @@ mergeIntCheap d = Event $ \sub -> do
20252052 )
20262053
20272054newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2055+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
20282056
2029−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2030−fan e =
2057+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2058+fanG e = unsafePerformIO $ do
2059+ ref <- newIORef Nothing
20312060 let f = Fan
20322061 { fanParent = e
2033− , fanSubscribed = unsafeNewIORef e Nothing
2062+ , fanSubscribed = ref
20342063 }
2035− in EventSelector $ \k -> eventFan k f
2064+ pure $ EventSelectorG $ \k -> eventFan k f
20362065
20372066runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
20382067runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2093,11 +2122,11 @@ runFrame a = SpiderHost $ do
20932122 return result
20942123 result <- runEventM go
20952124 toClear <- readIORef $ eventEnvClears env
2096− forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2125+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
20972126 toClearInt <- readIORef $ eventEnvIntClears env
2098− forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2127+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
20992128 toClearRoot <- readIORef $ eventEnvRootClears env
2100− forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2129+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
21012130 toAssign <- readIORef $ eventEnvAssignments env
21022131 toReconnectRef <- newIORef []
21032132 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
@@ -2457,9 +2486,9 @@ unsafeNewSpiderTimelineEnv = do
24572486
24582487-- | Create a new SpiderTimelineEnv
24592488newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2460−newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2489+newSpiderTimeline = withSpiderTimeline (pure . Some)
24612490
2462−data LocalSpiderTimeline x s
2491+data LocalSpiderTimeline (x :: Type) s
24632492
24642493instance Reifies s (SpiderTimelineEnv x) =>
24652494 HasSpiderTimeline (LocalSpiderTimeline x s) where
@@ -2477,11 +2506,11 @@ withSpiderTimeline k = do
24772506 env <- unsafeNewSpiderTimelineEnv
24782507 reify env $ \s -> k $ localSpiderTimeline s env
24792508
2480−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2509+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24812510
24822511type ComputeM = EventM
24832512
2484−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2513+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24852514
24862515instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
24872516 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
@@ -2501,10 +2530,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25012530 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
25022531 {-# INLINABLE pull #-}
25032532 pull = SpiderBehavior . pull . coerce
2504− {-# INLINABLE merge #-}
2505− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2506− {-# INLINABLE fan #-}
2507− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2533+ {-# INLINABLE fanG #-}
2534+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2535+ {-# INLINABLE mergeG #-}
2536+ mergeG
2537+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2538+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2539+ -> DMap k q
2540+ -> R.Event (SpiderTimeline x) (DMap k v)
2541+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
25082542 {-# INLINABLE switch #-}
25092543 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
25102544 {-# INLINABLE coincidence #-}
@@ -2517,10 +2551,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25172551 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
25182552 {-# INLINABLE unsafeBuildIncremental #-}
25192553 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2520− {-# INLINABLE mergeIncremental #-}
2521− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2522− {-# INLINABLE mergeIncrementalWithMove #-}
2523− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2554+ {-# INLINABLE mergeIncrementalG #-}
2555+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2556+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2557+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
25242558 {-# INLINABLE currentIncremental #-}
25252559 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
25262560 {-# INLINABLE updatedIncremental #-}
@@ -2558,7 +2592,7 @@ instance MonadAtomicRef (EventM x) where
25582592 atomicModifyRef r f = liftIO $ atomicModifyRef r f
25592593
25602594-- | The monad for actions that manipulate a Spider timeline identified by @x@
2561−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2595+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25622596
25632597instance Monad (SpiderHost x) where
25642598 {-# INLINABLE (>>=) #-}
@@ -2580,7 +2614,7 @@ runSpiderHost (SpiderHost a) = a
25802614runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
25812615runSpiderHostForTimeline (SpiderHost a) _ = a
25822616
2583−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2617+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
25842618 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25852619
25862620instance Monad (SpiderHostFrame x) where