@@ -38,7 +38,6 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
38import Control.Monad.Exception
38import Control.Monad.Exception
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Primitive
40import Control.Monad.Primitive
41−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42import Control.Monad.Reader.Class
41import Control.Monad.Reader.Class
43import Control.Monad.IO.Class
42import Control.Monad.IO.Class
44import Control.Monad.ReaderIO
43import Control.Monad.ReaderIO
@@ -61,13 +60,13 @@ import qualified Data.IntMap.Strict as IntMap
61import Data.IORef
60import Data.IORef
62import Data.Kind (Type)
61import Data.Kind (Type)
63import Data.Maybe hiding (mapMaybe)
62import Data.Maybe hiding (mapMaybe)
64−import Data.Monoid ((<>))
63+import Data.Monoid (mempty, (<>))
65import Data.Proxy
64import Data.Proxy
66import Data.These
65import Data.These
67import Data.Traversable
66import Data.Traversable
68import Data.Type.Equality ((:~:)(Refl))
67import Data.Type.Equality ((:~:)(Refl))
69import Data.Witherable (Filterable, mapMaybe)
68import Data.Witherable (Filterable, mapMaybe)
70−import GHC.Exts
69+import GHC.Exts hiding (toList)
71import GHC.IORef (IORef (..))
70import GHC.IORef (IORef (..))
72import GHC.Stack
71import GHC.Stack
73import Reflex.FastWeak
72import Reflex.FastWeak
@@ -86,14 +85,16 @@ import Data.Zip (Zip (..))
87#ifdef DEBUG_CYCLES
86#ifdef DEBUG_CYCLES
88import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
87import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
89import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
90import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
90import qualified Data.List.NonEmpty as NonEmpty
91import qualified Data.List.NonEmpty as NonEmpty
91−import Data.Monoid (mempty)
92import Data.Tree (Forest, Tree (..), drawForest)
92import Data.Tree (Forest, Tree (..), drawForest)
93−#endif
93+import Data.List (isPrefixOf)
95−import Data.FastWeakBag (FastWeakBag)
95+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
96import qualified Data.FastWeakBag as FastWeakBag
96import qualified Data.FastWeakBag as FastWeakBag
97import Data.Reflection
98import Data.Reflection
98import Data.Some (Some(Some))
99import Data.Some (Some(Some))
99import Data.Type.Coercion
100import Data.Type.Coercion
@@ -111,14 +112,19 @@ import Reflex.PerformEvent.Base (PerformEventT)
111#ifdef DEBUG_TRACE_EVENTS
112#ifdef DEBUG_TRACE_EVENTS
112import qualified Data.ByteString.Char8 as BS8
113import qualified Data.ByteString.Char8 as BS8
113import System.IO (stderr)
114import System.IO (stderr)
115+import Data.List (isPrefixOf)
116−#ifdef DEBUG_TRACE_EVENTS
118+-- TODO stdout might not be the best channel for debug output
119+debugStrLn :: String -> IO ()
120+debugStrLn = putStrLn
122+#ifdef DEBUG_TRACE_EVENTS
118withStackOneLine :: (BS8.ByteString -> a) -> a
123withStackOneLine :: (BS8.ByteString -> a) -> a
119withStackOneLine expr = unsafePerformIO $ do
124withStackOneLine expr = unsafePerformIO $ do
120 stack <- currentCallStack
125 stack <- currentCallStack
121− return (expr (BS8.pack (unwords (reverse stack))))
126+ return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
127+ where dropInternal = filterStack "Reflex.Spider.Internal"
@@ -129,28 +135,42 @@ debugInvalidateHeight :: Bool
129debugInvalidate :: Bool
135debugInvalidate :: Bool
131#ifdef DEBUG
137#ifdef DEBUG
133#define DEBUG_NODEIDS
138#define DEBUG_NODEIDS
140+#ifdef DEBUG_TRACE_PROPAGATION
135debugPropagate = True
141debugPropagate = True
143+debugPropagate = False
146+#ifdef DEBUG_TRACE_HEIGHT
147+debugInvalidateHeight = True
137debugInvalidateHeight = False
149debugInvalidateHeight = False
152+#ifdef DEBUG_TRACE_INVALIDATION
139debugInvalidate = True
153debugInvalidate = True
155+debugInvalidate = False
141class HasNodeId a where
158class HasNodeId a where
142 getNodeId :: a -> Int
159 getNodeId :: a -> Int
144−instance HasNodeId (Hold x p a) where
161+instance HasNodeId (CacheSubscribed x a) where
162+ getNodeId = _cacheSubscribed_nodeId
164+instance HasNodeId (FanInt x a) where
145− getNodeId = holdNodeId
165+ getNodeId = _fanInt_nodeId
147−instance HasNodeId (PushSubscribed x a b) where
167+instance HasNodeId (Hold x p) where
148− getNodeId = pushSubscribedNodeId
168+ getNodeId = holdNodeId
150instance HasNodeId (SwitchSubscribed x a) where
170instance HasNodeId (SwitchSubscribed x a) where
151 getNodeId = switchSubscribedNodeId
171 getNodeId = switchSubscribedNodeId
153−instance HasNodeId (FanSubscribed x a) where
173+instance HasNodeId (FanSubscribed x v a) where
154 getNodeId = fanSubscribedNodeId
174 getNodeId = fanSubscribedNodeId
156instance HasNodeId (CoincidenceSubscribed x a) where
176instance HasNodeId (CoincidenceSubscribed x a) where
@@ -164,41 +184,16 @@ instance HasNodeId (Pull x a) where
165{-# INLINE showNodeId #-}
185{-# INLINE showNodeId #-}
166showNodeId :: HasNodeId a => a -> String
186showNodeId :: HasNodeId a => a -> String
167−showNodeId = ("#"<>) . show . getNodeId
187+showNodeId = showNodeId' . getNodeId
169−showSubscriberType :: Subscriber x a -> String
189+showNodeId' :: Int -> String
170−showSubscriberType = \case
190+showNodeId' = ("#"<>) . show
171− SubscriberPush _ _ -> "SubscriberPush"
191+
172− SubscriberMerge _ _ -> "SubscriberMerge"
173− SubscriberFan _ -> "SubscriberFan"
174− SubscriberMergeChange _ -> "SubscriberMergeChange"
175− SubscriberHold _ -> "SubscriberHold"
176− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
177− SubscriberSwitch _ -> "SubscriberSwitch"
178− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
179− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
180− SubscriberHandle -> "SubscriberHandle"
182−showEventType :: Event x a -> String
183−showEventType = \case
184− EventRoot _ _ -> "EventRoot"
185− EventNever -> "EventNever"
186− EventPush _ -> "EventPush"
187− EventMerge _ -> "EventMerge"
188− EventFan _ _ -> "EventFan"
189− EventSwitch _ -> "EventSwitch"
190− EventCoincidence _ -> "EventCoincidence"
191− EventHold _ -> "EventHold"
192− EventDyn _ -> "EventDyn"
193− EventHoldIdentity _ -> "EventHoldIdentity"
194− EventDynIdentity _ -> "EventDynIdentity"
198debugPropagate = False
195debugPropagate = False
200debugInvalidateHeight = False
196debugInvalidateHeight = False
202debugInvalidate = False
197debugInvalidate = False
204-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
199-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
@@ -206,6 +201,10 @@ debugInvalidate = False
206showNodeId :: a -> String
201showNodeId :: a -> String
207showNodeId _ = ""
202showNodeId _ = ""
204+{-# INLINE showNodeId' #-}
205+showNodeId' :: Int -> String
211#ifdef DEBUG_NODEIDS
210#ifdef DEBUG_NODEIDS
@@ -251,9 +250,9 @@ subscribeAndRead = unEvent
251-- caching; if the computation function is very cheap, this is (much) more
250-- caching; if the computation function is very cheap, this is (much) more
252-- efficient than 'push'
251-- efficient than 'push'
253{-# INLINE [1] pushCheap #-}
252{-# INLINE [1] pushCheap #-}
254−pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
253+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
255pushCheap !f e = Event $ \sub -> do
254pushCheap !f e = Event $ \sub -> do
256− (subscription, occ) <- subscribeAndRead e $ sub
255+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
257 { subscriberPropagate = \a -> do
256 { subscriberPropagate = \a -> do
258 mb <- f a
257 mb <- f a
259 mapM_ (subscriberPropagate sub) mb
258 mapM_ (subscriberPropagate sub) mb
@@ -272,10 +271,10 @@ terminalSubscriber p = Subscriber
273-- | Subscribe to an Event only for the duration of one occurrence
272-- | Subscribe to an Event only for the duration of one occurrence
274{-# INLINE subscribeAndReadHead #-}
273{-# INLINE subscribeAndReadHead #-}
275−subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
274+subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
276subscribeAndReadHead e sub = do
275subscribeAndReadHead e sub = do
277 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
276 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
278− (subscription, occ) <- subscribeAndRead e $ sub
277+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub
279 { subscriberPropagate = \a -> do
278 { subscriberPropagate = \a -> do
280 liftIO $ unsubscribe =<< readIORef subscriptionRef
279 liftIO $ unsubscribe =<< readIORef subscriptionRef
281 subscriberPropagate sub a
280 subscriberPropagate sub a
@@ -286,24 +285,29 @@ subscribeAndReadHead e sub = do
286 return (subscription, occ)
285 return (subscription, occ)
288--TODO: Make this lazy in its input event
287--TODO: Make this lazy in its input event
289−headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
288+headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)
290headE originalE = do
289headE originalE = do
291 parent <- liftIO $ newIORef $ Just originalE
290 parent <- liftIO $ newIORef $ Just originalE
292 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
291 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
293 let clearParent = liftIO $ writeIORef parent Nothing
292 let clearParent = liftIO $ writeIORef parent Nothing
294− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
293+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
295 when (isJust occ) clearParent
294 when (isJust occ) clearParent
296− return $ Event $ \sub -> do
295+ return $ Event $ \sub ->
297 liftIO (readIORef parent) >>= \case
296 liftIO (readIORef parent) >>= \case
298− Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
297+ Nothing -> subscribeAndReadNever
299 Just e -> subscribeAndReadHead e sub
298 Just e -> subscribeAndReadHead e sub
301data CacheSubscribed x a
300data CacheSubscribed x a
302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
301 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
302 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
303 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
305+ , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int
307-- | Construct an 'Event' whose value is guaranteed not to be recomputed
311-- | Construct an 'Event' whose value is guaranteed not to be recomputed
308-- repeatedly
312-- repeatedly
@@ -328,18 +332,23 @@ cacheEvent e =
328 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
332 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
329 Just subscribedTicket -> return subscribedTicket
333 Just subscribedTicket -> return subscribedTicket
330 Nothing -> do
334 Nothing -> do
336+ nodeId <- liftIO newNodeId
331 subscribers <- liftIO FastWeakBag.empty
338 subscribers <- liftIO FastWeakBag.empty
332 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
339 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
341+ (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber
333 (parentSub, occ) <- subscribeAndRead e $ Subscriber
343 (parentSub, occ) <- subscribeAndRead e $ Subscriber
334− { subscriberPropagate = \a -> do
345+ { subscriberPropagate = \a -> do
335− liftIO $ writeIORef occRef $ Just a
346+ liftIO $ writeIORef occRef (Just a)
336− scheduleClear occRef
347+ scheduleClear occRef
337− propagateFast a subscribers
348+ propagateFast a subscribers
338− , subscriberInvalidateHeight = \old -> do
339− FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old
349+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight
340− , subscriberRecalculateHeight = \new -> do
341− FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new
350+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight
343 when (isJust occ) $ do
352 when (isJust occ) $ do
344 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
353 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
345 scheduleClear occRef
354 scheduleClear occRef
@@ -347,29 +356,45 @@ cacheEvent e =
347 { _cacheSubscribed_subscribers = subscribers
356 { _cacheSubscribed_subscribers = subscribers
348 , _cacheSubscribed_parent = parentSub
357 , _cacheSubscribed_parent = parentSub
349 , _cacheSubscribed_occurrence = occRef
358 , _cacheSubscribed_occurrence = occRef
360+ , _cacheSubscribed_nodeId = nodeId
351 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
363 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
352 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
364 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
353 return subscribedTicket
365 return subscribedTicket
354− liftIO $ do
366+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
368+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
369+ -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
370+cacheSubscription sub mSubscribedRef subscribedTicket = do
355− subscribed <- getFastWeakTicketValue subscribedTicket
371+ subscribed <- getFastWeakTicketValue subscribedTicket
356− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
372+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
357− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
373+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
375+ let parentSub = _cacheSubscribed_parent subscribed
358− let es = EventSubscription
376+ es = EventSubscription
359− { _eventSubscription_unsubscribe = do
377+ { _eventSubscription_unsubscribe = do
360− FastWeakBag.remove ticket
378+ FastWeakBag.remove ticket
361− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
380+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
362− when isEmpty $ do
381+ when isEmpty $ do
363− writeIORef mSubscribedRef emptyFastWeak
382+ writeIORef mSubscribedRef emptyFastWeak
364− unsubscribe $ _cacheSubscribed_parent subscribed
383+ unsubscribe parentSub
365− touch ticket
384+ touch ticket
366− touch subscribedTicket
385+ touch subscribedTicket
367− , _eventSubscription_subscribed = EventSubscribed
386+ , _eventSubscription_subscribed = EventSubscribed
368− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
387+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub
369− , eventSubscribedRetained = toAny subscribedTicket
388+ , eventSubscribedRetained = toAny subscribedTicket
390+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
391+ , eventSubscribedHasOwnHeightRef = False
392+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
372− return (es, occ)
396+ return (es, occ)
374subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
399subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
375subscribe e s = fst <$> subscribeAndRead e s
400subscribe e s = fst <$> subscribeAndRead e s
@@ -381,11 +406,14 @@ wrap tag getSpecificSubscribed sub = do
381 let es = tag subd
406 let es = tag subd
382 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
407 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
384−eventRoot :: GCompare k => k a -> Root x k -> Event x a
409+eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
385eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
410eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
412+subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
413+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
387eventNever :: Event x a
415eventNever :: Event x a
388−eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
416+eventNever = Event $ const subscribeAndReadNever
390eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
418eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
391eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
419eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
@@ -440,10 +468,10 @@ newSubscriberHold h = return $ Subscriber
442newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
470newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
443−newSubscriberFan subscribed = return $ Subscriber
471+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
444 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
472 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
445 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
473 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
446− tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
474+ tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
447 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
475 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
448 scheduleClear $ fanSubscribedOccurrence subscribed
476 scheduleClear $ fanSubscribedOccurrence subscribed
449 let f _ (Pair v subsubs) = do
477 let f _ (Pair v subsubs) = do
@@ -452,50 +480,40 @@ newSubscriberFan subscribed = return $ Subscriber
452 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
480 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
453 return ()
481 return ()
454 , subscriberInvalidateHeight = \old -> do
482 , subscriberInvalidateHeight = \old -> do
455− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
456 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
483 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
457 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
484 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
458− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
459 , subscriberRecalculateHeight = \new -> do
485 , subscriberRecalculateHeight = \new -> do
460− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
461 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
486 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
462 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
487 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
463− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
466newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
490newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
467−newSubscriberSwitch subscribed = return $ Subscriber
491+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
468 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
492 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
469− tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
470 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
493 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
471 scheduleClear $ switchSubscribedOccurrence subscribed
494 scheduleClear $ switchSubscribedOccurrence subscribed
472 propagate a $ switchSubscribedSubscribers subscribed
495 propagate a $ switchSubscribedSubscribers subscribed
473 , subscriberInvalidateHeight = \_ -> do
496 , subscriberInvalidateHeight = \_ -> do
474− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
475 oldHeight <- readIORef $ switchSubscribedHeight subscribed
497 oldHeight <- readIORef $ switchSubscribedHeight subscribed
476 when (oldHeight /= invalidHeight) $ do
498 when (oldHeight /= invalidHeight) $ do
477 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
499 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
478 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
500 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
479− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
480− , subscriberRecalculateHeight = \new -> do
501+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
481− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
482− updateSwitchHeight new subscribed
483− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
486newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
504newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
487−newSubscriberCoincidenceOuter subscribed = return $ Subscriber
505+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
488 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
506 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
489− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
490 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
507 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
491 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
508 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
492 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
509 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
493 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
510 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
494 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
511 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
495 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
513 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
496 scheduleClear $ coincidenceSubscribedInnerParent subscribed
514 scheduleClear $ coincidenceSubscribedInnerParent subscribed
497 case occ of
515 case occ of
498− Nothing -> do
516+ Nothing ->
499 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
517 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
500 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
518 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
501 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
519 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
@@ -504,20 +522,13 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber
504 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
522 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
505 scheduleClear $ coincidenceSubscribedOccurrence subscribed
523 scheduleClear $ coincidenceSubscribedOccurrence subscribed
506 propagate o $ coincidenceSubscribedSubscribers subscribed
524 propagate o $ coincidenceSubscribedSubscribers subscribed
507− , subscriberInvalidateHeight = \_ -> do
508− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
509− invalidateCoincidenceHeight subscribed
525+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
510− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
511− , subscriberRecalculateHeight = \_ -> do
512− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
513− recalculateCoincidenceHeight subscribed
526+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
514− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
517newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
529newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
518−newSubscriberCoincidenceInner subscribed = return $ Subscriber
530+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber
519 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
531 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
520− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
521 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
532 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
522 case occ of
533 case occ of
523 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
534 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
@@ -525,14 +536,8 @@ newSubscriberCoincidenceInner subscribed = return $ Subscriber
525 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
536 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
526 scheduleClear $ coincidenceSubscribedOccurrence subscribed
537 scheduleClear $ coincidenceSubscribedOccurrence subscribed
527 propagate a $ coincidenceSubscribedSubscribers subscribed
538 propagate a $ coincidenceSubscribedSubscribers subscribed
528− , subscriberInvalidateHeight = \_ -> do
529− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
530− invalidateCoincidenceHeight subscribed
539+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
531− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
532− , subscriberRecalculateHeight = \_ -> do
533− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
534− recalculateCoincidenceHeight subscribed
540+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
535− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
538invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
543invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
@@ -542,15 +547,15 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
542recalculateSubscriberHeight = flip subscriberRecalculateHeight
547recalculateSubscriberHeight = flip subscriberRecalculateHeight
544-- | Propagate everything at the current height
549-- | Propagate everything at the current height
545−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
550+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
546−propagate a subscribers = withIncreasedDepth $ do
551+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
547 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
552 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
548 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
553 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
549 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
554 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
551-- | Propagate everything at the current height
556-- | Propagate everything at the current height
552−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
557+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
553−propagateFast a subscribers = withIncreasedDepth $ do
558+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
554 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
559 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
555 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
560 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
556 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
561 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
@@ -571,7 +576,7 @@ data EventSubscribed x = EventSubscribed
571 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
576 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
572 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
577 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
573#ifdef DEBUG_CYCLES
578#ifdef DEBUG_CYCLES
574− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
579+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
575 , eventSubscribedHasOwnHeightRef :: !Bool
580 , eventSubscribedHasOwnHeightRef :: !Bool
576 , eventSubscribedWhoCreated :: !(IO [String])
581 , eventSubscribedWhoCreated :: !(IO [String])
@@ -604,7 +609,7 @@ eventSubscribedFan !subscribed = EventSubscribed
604 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
609 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
605 , eventSubscribedRetained = toAny subscribed
610 , eventSubscribedRetained = toAny subscribed
606#ifdef DEBUG_CYCLES
611#ifdef DEBUG_CYCLES
607− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
612+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
608 , eventSubscribedHasOwnHeightRef = False
613 , eventSubscribedHasOwnHeightRef = False
609 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
614 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
@@ -617,7 +622,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
617#ifdef DEBUG_CYCLES
622#ifdef DEBUG_CYCLES
618 , eventSubscribedGetParents = do
623 , eventSubscribedGetParents = do
619 s <- readIORef $ switchSubscribedCurrentParent subscribed
624 s <- readIORef $ switchSubscribedCurrentParent subscribed
620− return [Some $ _eventSubscription_subscribed s]
625+ return [_eventSubscription_subscribed s]
621 , eventSubscribedHasOwnHeightRef = True
626 , eventSubscribedHasOwnHeightRef = True
622 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
627 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
@@ -630,8 +635,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
630#ifdef DEBUG_CYCLES
635#ifdef DEBUG_CYCLES
631 , eventSubscribedGetParents = do
636 , eventSubscribedGetParents = do
632 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
637 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
633− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
638+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
634− innerParents = maybeToList $ fmap Some innerSubscription
639+ innerParents = maybeToList $ innerSubscription
635 return $ outerParent : innerParents
640 return $ outerParent : innerParents
636 , eventSubscribedHasOwnHeightRef = True
641 , eventSubscribedHasOwnHeightRef = True
637 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
642 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -645,15 +650,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
645whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
650whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
646whoCreatedEventSubscribed = eventSubscribedWhoCreated
651whoCreatedEventSubscribed = eventSubscribedWhoCreated
648−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
653+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
649walkInvalidHeightParents s0 = do
654walkInvalidHeightParents s0 = do
650− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
655+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
651 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
656 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
652 when (h == invalidHeight) $ do
657 when (h == invalidHeight) $ do
653 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
658 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
654− modify (Some s :)
659+ modify (s :)
655 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
660 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
656− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
661+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
657 return subscribers
662 return subscribers
@@ -1038,7 +1043,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
1038newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1043newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1040-- EventM can do everything BehaviorM can, plus create holds
1045-- EventM can do everything BehaviorM can, plus create holds
1041−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
1046+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1043newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1048newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
@@ -1063,7 +1068,8 @@ heightBagFromList :: [Height] -> HeightBag
1063heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1068heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1065heightBagAdd :: Height -> HeightBag -> HeightBag
1070heightBagAdd :: Height -> HeightBag -> HeightBag
1066−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1071+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1072+ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1068heightBagRemove :: Height -> HeightBag -> HeightBag
1074heightBagRemove :: Height -> HeightBag -> HeightBag
1069heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1075heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
@@ -1072,6 +1078,13 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo
1072 0 -> IntMap.delete h c
1078 0 -> IntMap.delete h c
1073 _ -> IntMap.insert h (pred old) c
1079 _ -> IntMap.insert h (pred old) c
1081+heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag
1082+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
1083+ removed old = HeightBag (pred s) $ case old of
1084+ 0 -> IntMap.delete h c
1085+ _ -> IntMap.insert h (pred old) c
1075heightBagMax :: HeightBag -> Height
1088heightBagMax :: HeightBag -> Height
1076heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1089heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1077 Just ((h, _), _) -> Height h
1090 Just ((h, _), _) -> Height h
@@ -1319,55 +1332,110 @@ mkWeakPtrWithDebug x debugNote = do
1319 x' <- evaluate x
1332 x' <- evaluate x
1320 mkWeakPtr x' $
1333 mkWeakPtr x' $
1321 if debugFinalize
1334 if debugFinalize
1322− then Just $ putStrLn $ "finalizing: " ++ debugNote
1335+ then Just $ debugStrLn $ "finalizing: " ++ debugNote
1323 else Nothing
1336 else Nothing
1325type WeakList a = [Weak a]
1338type WeakList a = [Weak a]
1327−{-# INLINE withIncreasedDepth #-}
1340+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1328#ifdef DEBUG
1345#ifdef DEBUG
1347+debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1348+debugSubscriber description = return . debugSubscriber' description
1350+debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a
1351+debugSubscriber' description subscribed = Subscriber
1353+ subscriberPropagate = \m -> do
1354+ tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1355+ subscriberPropagate subscribed m
1356+ , subscriberInvalidateHeight = \old -> do
1357+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1358+ subscriberInvalidateHeight subscribed old
1359+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
1360+ , subscriberRecalculateHeight = \new -> do
1361+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1362+ subscriberRecalculateHeight subscribed new
1363+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
1329−withIncreasedDepth :: CanTrace x m => m a -> m a
1367+{-# INLINE withIncreasedDepth #-}
1368+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1330−withIncreasedDepth a = do
1369+withIncreasedDepth _ a = do
1331− spiderTimeline <- askSpiderTimelineEnv
1332− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1370+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ
1333 result <- a
1371 result <- a
1334− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1372+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
1335 return result
1373 return result
1337−withIncreasedDepth :: m a -> m a
1338−withIncreasedDepth = id
1341−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1343{-# INLINE tracePropagate #-}
1375{-# INLINE tracePropagate #-}
1344tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1376tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1345−tracePropagate p = traceWhen p debugPropagate
1377+tracePropagate p = when debugPropagate . trace p
1347{-# INLINE traceInvalidate #-}
1379{-# INLINE traceInvalidate #-}
1348traceInvalidate :: String -> IO ()
1380traceInvalidate :: String -> IO ()
1349−traceInvalidate = when debugInvalidate . liftIO . putStrLn
1381+traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1383+{-# INLINE traceInvalidateHeight #-}
1384+traceInvalidateHeight :: String -> IO ()
1385+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1351−{-# INLINE traceWhen #-}
1387+{-# INLINE trace #-}
1352−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1388+trace :: (CanTrace x m) => proxy x -> String -> m ()
1353−traceWhen p b message = traceMWhen p b $ return message
1389+trace p message = traceM p $ return message
1355−{-# INLINE traceMWhen #-}
1391+{-# INLINE traceM #-}
1356−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1392+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1357−traceMWhen _ b getMessage = when b $ do
1393+traceM _ getMessage = do
1358 message <- getMessage
1394 message <- getMessage
1360− spiderTimeline <- askSpiderTimelineEnv
1361− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1395+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1396+ liftIO $ debugStrLn $ replicate d ' ' <> message
1400+{-# INLINE withIncreasedDepth #-}
1401+withIncreasedDepth :: proxy x -> m a -> m a
1402+withIncreasedDepth _ = id
1404+{-# INLINE tracePropagate #-}
1405+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1406+tracePropagate _ _ = return ()
1408+{-# INLINE traceInvalidate #-}
1409+traceInvalidate :: String -> IO ()
1410+traceInvalidate _ = return ()
1412+{-# INLINE traceInvalidateHeight #-}
1413+traceInvalidateHeight :: String -> IO ()
1414+traceInvalidateHeight _ = return ()
1416+{-# INLINE debugSubscriber #-}
1417+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1418+debugSubscriber _ = return
1420+{-# INLINE debugSubscriber' #-}
1421+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a
1422+debugSubscriber' _ = id
1426+{-# INLINE trace #-}
1427+trace :: (CanTrace x m) => proxy x -> String -> m ()
1428+trace _ _ = return ()
1430+{-# INLINE traceM #-}
1431+traceM :: (CanTrace x m) => proxy x -> m String -> m ()
1432+traceM _ _ = return ()
1365− liftIO $ putStrLn $ replicate d ' ' <> message
1367whoCreatedIORef :: IORef a -> IO [String]
1436whoCreatedIORef :: IORef a -> IO [String]
1368whoCreatedIORef (IORef a) = whoCreated $! a
1437whoCreatedIORef (IORef a) = whoCreated $! a
1371groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1439groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1372groupByHead = \case
1440groupByHead = \case
1373 [] -> []
1441 [] -> []
@@ -1378,20 +1446,54 @@ groupByHead = \case
1378 | otherwise -> (x, xs :| []) : l
1446 | otherwise -> (x, xs :| []) : l
1380listsToForest :: Eq a => [[a]] -> Forest a
1448listsToForest :: Eq a => [[a]] -> Forest a
1381−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1449+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)
1450+ where buildForest (a, lists') = Node a $ listsToForest $ toList lists'
1452+showStacks :: [[String]] -> String
1453+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1455+filterStack :: String -> [String] -> [String]
1456+#ifdef DEBUG_HIDE_INTERNALS
1457+filterStack prefix = filter (not . (prefix `isPrefixOf`))
1459+filterStack prefix = id
1464+data EventLoopException = EventLoopException [[String]]
1465+instance Exception EventLoopException
1467+instance Show EventLoopException where
1468+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1469+ then "no location information, compile with profiling enabled for stack tree"
1470+ else showStacks stacks
1474+data EventLoopException = EventLoopException
1475+instance Exception EventLoopException
1477+instance Show EventLoopException where
1478+ show EventLoopException = "causality loop detected: \n" <>
1479+ "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"
1384{-# INLINE propagateSubscriberHold #-}
1484{-# INLINE propagateSubscriberHold #-}
1385propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1485propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1386propagateSubscriberHold h a = do
1486propagateSubscriberHold h a = do
1387− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1487+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1388 invalidators <- liftIO $ readIORef $ holdInvalidators h
1488 invalidators <- liftIO $ readIORef $ holdInvalidators h
1389 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1489 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1390 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1491 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1391 case {-# SCC "apply" #-} apply a v of
1492 case {-# SCC "apply" #-} apply a v of
1392 Nothing -> return ()
1493 Nothing -> return ()
1393 Just v' -> do
1494 Just v' -> do
1495+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1394− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1496+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1395 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1497 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1396 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1498 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1397 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1499 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1445,7 +1547,7 @@ getDynHold d = do
1445zeroRef :: IORef Height
1547zeroRef :: IORef Height
1446zeroRef = unsafePerformIO $ newIORef zeroHeight
1548zeroRef = unsafePerformIO $ newIORef zeroHeight
1448−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1550+getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1449getRootSubscribed k r sub = do
1551getRootSubscribed k r sub = do
1450 mSubscribed <- readIORef $ rootSubscribed r
1552 mSubscribed <- readIORef $ rootSubscribed r
1451 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1553 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
@@ -1459,7 +1561,9 @@ getRootSubscribed k r sub = do
1459 let !cached = rootSubscribed r
1561 let !cached = rootSubscribed r
1460 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1562 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1461 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1563 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1462− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1565+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1463 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1567 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1464 writeIORef uninitRef $! uninit
1568 writeIORef uninitRef $! uninit
1465#ifdef DEBUG_NODEIDS
1569#ifdef DEBUG_NODEIDS
@@ -1509,6 +1613,9 @@ data FanInt x a = FanInt
1509 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1613 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1510 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1614 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1511 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1615 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1616+#ifdef DEBUG_NODEIDS
1617+ , _fanInt_nodeId :: {-# UNPACK #-} !Int
1514newFanInt :: IO (FanInt x a)
1621newFanInt :: IO (FanInt x a)
@@ -1516,10 +1623,16 @@ newFanInt = do
1516 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1623 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1517 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1624 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1518 occRef <- newIORef $ error "fanInt: no occurrence"
1625 occRef <- newIORef $ error "fanInt: no occurrence"
1626+#ifdef DEBUG_NODEIDS
1627+ nodeId <- newNodeId
1519 return $ FanInt
1629 return $ FanInt
1520 { _fanInt_subscribers = subscribers
1630 { _fanInt_subscribers = subscribers
1521 , _fanInt_subscriptionRef = subscriptionRef
1631 , _fanInt_subscriptionRef = subscriptionRef
1522 , _fanInt_occRef = occRef
1632 , _fanInt_occRef = occRef
1633+#ifdef DEBUG_NODEIDS
1634+ , _fanInt_nodeId = nodeId
1525fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1638fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
@@ -1528,20 +1641,21 @@ fanInt p = unsafePerformIO $ do
1528 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1641 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1529 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1642 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1530 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1643 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1644+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k
1531− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1645+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber
1532 { subscriberPropagate = \m -> do
1646 { subscriberPropagate = \m -> do
1533 liftIO $ writeIORef (_fanInt_occRef self) m
1647 liftIO $ writeIORef (_fanInt_occRef self) m
1534 scheduleIntClear $ _fanInt_occRef self
1648 scheduleIntClear $ _fanInt_occRef self
1535− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1649+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1536− FastWeakBag.traverse_ b $ \s -> do
1650+ FastWeakBag.traverse_ b $ \s ->
1537 subscriberPropagate s v
1651 subscriberPropagate s v
1538− , subscriberInvalidateHeight = \old -> do
1652+ , subscriberInvalidateHeight = \old ->
1539− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1653+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1540− FastWeakBag.traverse_ b $ \s -> do
1654+ FastWeakBag.traverse_ b $ \s ->
1541 subscriberInvalidateHeight s old
1655 subscriberInvalidateHeight s old
1542− , subscriberRecalculateHeight = \new -> do
1656+ , subscriberRecalculateHeight = \new ->
1543− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1657+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1544− FastWeakBag.traverse_ b $ \s -> do
1658+ FastWeakBag.traverse_ b $ \s ->
1545 subscriberRecalculateHeight s new
1659 subscriberRecalculateHeight s new
1547 liftIO $ do
1661 liftIO $ do
@@ -1555,10 +1669,25 @@ fanInt p = unsafePerformIO $ do
1555 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1669 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1556 return b
1670 return b
1557 Just b -> return b
1671 Just b -> return b
1558− t <- liftIO $ FastWeakBag.insert sub b
1672+ ticket <- liftIO $ FastWeakBag.insert sub b
1559 currentOcc <- readIORef (_fanInt_occRef self)
1673 currentOcc <- readIORef (_fanInt_occRef self)
1560− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1674+
1675+ subscribed <- fanIntSubscribed ticket self
1561− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1676+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1678+fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1679+fanIntSubscribed ticket self = do
1680+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1681+ return $ EventSubscribed
1682+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1683+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1685+ , eventSubscribedGetParents = return [subscribedParent]
1686+ , eventSubscribedHasOwnHeightRef = False
1687+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1563{-# INLINABLE getFanSubscribed #-}
1692{-# INLINABLE getFanSubscribed #-}
1564getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1693getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
@@ -1756,7 +1885,7 @@ mergeCheap
1756 => (forall a. q a -> Event x (v a))
1885 => (forall a. q a -> Event x (v a))
1757 -> DynamicS x (PatchDMap k q)
1886 -> DynamicS x (PatchDMap k q)
1758 -> Event x (DMap k v)
1887 -> Event x (DMap k v)
1759−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1888+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy
1761 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1890 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1762 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1891 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
@@ -1771,7 +1900,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1771 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1900 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1772 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1901 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1773 forM_ mOldSubd $ \oldSubd -> do
1902 forM_ mOldSubd $ \oldSubd -> do
1903+ oldHeight <- liftIO $ getEventSubscribedHeight $
1774− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1904+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1775 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1906 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1776 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1907 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1777 foldM f ([], oldParents) $ DMap.toList p
1908 foldM f ([], oldParents) $ DMap.toList p
@@ -1796,7 +1927,7 @@ mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1796 => (forall a. q a -> Event x (v a))
1927 => (forall a. q a -> Event x (v a))
1797 -> DynamicS x (PatchDMapWithMove k q)
1928 -> DynamicS x (PatchDMapWithMove k q)
1798 -> Event x (DMap k v)
1929 -> Event x (DMap k v)
1799−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1930+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy
1801 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1932 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1802 updateMe subscriber heightBagRef oldParents p = do
1933 updateMe subscriber heightBagRef oldParents p = do
@@ -1815,13 +1946,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1815 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1946 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1816 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1947 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1817 Nothing -> do
1948 Nothing -> do
1818− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1949+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1950+ _mergeSubscribedParentWithMove_subscription parent
1819 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1952 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1820 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1953 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1821 Just toKey -> do
1954 Just toKey -> do
1822 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1955 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1823 return Nothing
1956 return Nothing
1957+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1824− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1958+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1825 return (toDelete, applyAlways p' oldParents)
1960 return (toDelete, applyAlways p' oldParents)
1826 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1961 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1827 getInitialSubscribers initialParents subscriber = do
1962 getInitialSubscribers initialParents subscriber = do
@@ -1846,6 +1981,8 @@ type MergeUpdateFunc k v x p s
1847 -> EventM x ([EventSubscription x], DMap k s)
1982 -> EventM x ([EventSubscription x], DMap k s)
1984+type MergeGetSubscription x s = forall a. s a -> EventSubscription x
1849type MergeInitFunc k v q x s
1986type MergeInitFunc k v q x s
1850 = DMap k q
1987 = DMap k q
1851 -> (forall a. EventM x (k a) -> Subscriber x (v a))
1988 -> (forall a. EventM x (k a) -> Subscriber x (v a))
@@ -1869,14 +2006,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su
1869invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
2006invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1870invalidateMergeHeight' heightRef sub = do
2007invalidateMergeHeight' heightRef sub = do
1871 oldHeight <- readIORef heightRef
2008 oldHeight <- readIORef heightRef
1872− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
2009+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
2010+ when (oldHeight /= invalidHeight) $ do
1873 writeIORef heightRef $! invalidHeight
2011 writeIORef heightRef $! invalidHeight
1874 subscriberInvalidateHeight sub oldHeight
2012 subscriberInvalidateHeight sub oldHeight
1876revalidateMergeHeight :: Merge x k v s -> IO ()
2014revalidateMergeHeight :: Merge x k v s -> IO ()
1877revalidateMergeHeight m = do
2015revalidateMergeHeight m = do
1878 currentHeight <- readIORef $ _merge_heightRef m
2016 currentHeight <- readIORef $ _merge_heightRef m
1879− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
2018+ -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
2019+ when (currentHeight == invalidHeight) $ do
1880 heights <- readIORef $ _merge_heightBagRef m
2020 heights <- readIORef $ _merge_heightBagRef m
1881 parents <- readIORef $ _merge_parentsRef m
2021 parents <- readIORef $ _merge_parentsRef m
1882 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
2022 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -1884,7 +2024,7 @@ revalidateMergeHeight m = do
1884 LT -> return ()
2024 LT -> return ()
1885 EQ -> do
2025 EQ -> do
1886 let height = succHeight $ heightBagMax heights
2026 let height = succHeight $ heightBagMax heights
1887− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
2027+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1888 writeIORef (_merge_heightRef m) $! height
2028 writeIORef (_merge_heightRef m) $! height
1889 subscriberRecalculateHeight (_merge_sub m) height
2029 subscriberRecalculateHeight (_merge_sub m) height
1890 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
2030 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -1892,36 +2032,45 @@ revalidateMergeHeight m = do
1892scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
2032scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1893scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
2033scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1894 vals <- liftIO $ readIORef $ _merge_accumRef m
2034 vals <- liftIO $ readIORef $ _merge_accumRef m
1895− 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
2035+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
2036+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
2037+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
1896 --TODO: Assert that m is not empty
2038 --TODO: Assert that m is not empty
1897 subscriberPropagate (_merge_sub m) vals
2039 subscriberPropagate (_merge_sub m) vals
2041+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()
2042+checkCycle subscribed = liftIO $ do
2043+ height <- readIORef (eventSubscribedHeightRef subscribed)
2045+ -- currentHeight <- getCurrentHeight
2046+ -- when (height <= currentHeight) $ if height /= invalidHeight
2048+ -- myStack <- liftIO $ whoCreatedIORef undefined --TODO
2049+ -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
2051+ when (height == invalidHeight) $
2054+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
2055+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
2056+ throwIO (EventLoopException stacks)
2058+ throwIO EventLoopException
1899−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
2062+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1900−mergeSubscriber m getKey = Subscriber
2063+mergeSubscriber subscribed m getKey = Subscriber
1901 { subscriberPropagate = \a -> do
2064 { subscriberPropagate = \a -> do
1902 oldM <- liftIO $ readIORef $ _merge_accumRef m
2065 oldM <- liftIO $ readIORef $ _merge_accumRef m
1903 k <- getKey
2066 k <- getKey
1904− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
2067+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
1905 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
2068 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1906 liftIO $ writeIORef (_merge_accumRef m) $! newM
2069 liftIO $ writeIORef (_merge_accumRef m) $! newM
1907 when (DMap.null oldM) $ do -- Only schedule the firing once
2070 when (DMap.null oldM) $ do -- Only schedule the firing once
1908 height <- liftIO $ readIORef $ _merge_heightRef m
2071 height <- liftIO $ readIORef $ _merge_heightRef m
1909− --TODO: assertions about height
2072+ checkCycle subscribed
1910− currentHeight <- getCurrentHeight
2073+
1911− when (height <= currentHeight) $ do
1912− if height /= invalidHeight
1914− myStack <- liftIO $ whoCreatedIORef undefined --TODO
1915− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1918− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1919− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1920− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1924− error $ "Causality loop found" <> cycleInfo
1925 scheduleMergeSelf m height
2074 scheduleMergeSelf m height
1926 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
2075 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1927 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
2076 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
@@ -1932,31 +2081,45 @@ mergeSubscriber m getKey = Subscriber
1934--TODO: Be able to run as much of this as possible promptly
2083--TODO: Be able to run as much of this as possible promptly
1935−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
2084+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1936−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
2085+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1937 where updateMe = do
2086 where updateMe = do
1938 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
2087 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1939− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
2088+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
1940 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
2089 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1941 return subscriptionsToKill
2090 return subscriptionsToKill
1943{-# INLINE mergeGCheap' #-}
2092{-# INLINE mergeGCheap' #-}
1944mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
2093mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1945− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
2094+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1946−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
2095+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1947 initialParents <- readBehaviorUntracked $ dynamicCurrent d
2096 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1948 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
2097 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1949 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
2098 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1950 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
2099 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1951 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
2100 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
2101+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2103+ let subscribed = EventSubscribed
2104+ { eventSubscribedHeightRef = heightRef
2105+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2107+ , eventSubscribedGetParents = do
2108+ let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)
2109+ fmap getParent' . DMap.toList <$> readIORef parentsRef
2110+ , eventSubscribedHasOwnHeightRef = False
2111+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
1952− let m = Merge
2115+ m = Merge
1953 { _merge_parentsRef = parentsRef
2116 { _merge_parentsRef = parentsRef
1954 , _merge_heightBagRef = heightBagRef
2117 , _merge_heightBagRef = heightBagRef
1955 , _merge_heightRef = heightRef
2118 , _merge_heightRef = heightRef
1956 , _merge_sub = sub
2119 , _merge_sub = sub
1957 , _merge_accumRef = accumRef
2120 , _merge_accumRef = accumRef
1959− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
2122+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
1960 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
2123 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1961 myHeight = if invalidHeight `elem` heights
2124 myHeight = if invalidHeight `elem` heights
1962 then invalidHeight
2125 then invalidHeight
@@ -1965,31 +2128,29 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1965 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
2128 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1966 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
2129 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1967 else (Nothing, dm)
2130 else (Nothing, dm)
1968− unless (DMap.null accum) $ do
1969− scheduleMergeSelf m myHeight
2131+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight
1970 liftIO $ writeIORef accumRef $! accum
2132 liftIO $ writeIORef accumRef $! accum
1971 liftIO $ writeIORef heightRef $! myHeight
2133 liftIO $ writeIORef heightRef $! myHeight
1972 liftIO $ writeIORef heightBagRef $! myHeightBag
2134 liftIO $ writeIORef heightBagRef $! myHeightBag
1973− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1974 liftIO $ writeIORef parentsRef $! initialParentState
2135 liftIO $ writeIORef parentsRef $! initialParentState
1975 defer $ SomeMergeInit $ do
2136 defer $ SomeMergeInit $ do
1976− let s = Subscriber
2137+ let changeSubscriber = Subscriber
1977 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2138 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1978− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
2139+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
1979− defer $ updateMerge m updateFunc a
2140+ defer $ updateMerge subscribed m updateFunc a
1980 , subscriberInvalidateHeight = \_ -> return ()
2141 , subscriberInvalidateHeight = \_ -> return ()
1981 , subscriberRecalculateHeight = \_ -> return ()
2142 , subscriberRecalculateHeight = \_ -> return ()
1983− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2144+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
1984− forM_ change $ \c -> defer $ updateMerge m updateFunc c
2145+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
1985 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2146 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1986 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2147 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1987 -- its subscription.
2148 -- its subscription.
1988− liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2149+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
1989 let unsubscribeAll = destroy =<< readIORef parentsRef
2150 let unsubscribeAll = destroy =<< readIORef parentsRef
1990− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
2152+ return (EventSubscription unsubscribeAll subscribed, occ)
1994mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2155mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1995mergeInt = cacheEvent . mergeIntCheap
2156mergeInt = cacheEvent . mergeIntCheap
@@ -2002,13 +2163,22 @@ mergeIntCheap d = Event $ \sub -> do
2002 heightRef <- liftIO $ newIORef zeroHeight
2163 heightRef <- liftIO $ newIORef zeroHeight
2003 heightBagRef <- liftIO $ newIORef heightBagEmpty
2164 heightBagRef <- liftIO $ newIORef heightBagEmpty
2004 parents <- liftIO $ FastMutableIntMap.newEmpty
2165 parents <- liftIO $ FastMutableIntMap.newEmpty
2166+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2167+ let subscribed = EventSubscribed
2168+ { eventSubscribedHeightRef = heightRef
2169+ , eventSubscribedRetained = toAny (parents, changeSubdRef)
2171+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2172+ , eventSubscribedHasOwnHeightRef = False
2173+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2005 let scheduleSelf = do
2176 let scheduleSelf = do
2006 height <- liftIO $ readIORef $ heightRef
2177 height <- liftIO $ readIORef $ heightRef
2007 scheduleMerge' height heightRef $ do
2178 scheduleMerge' height heightRef $ do
2008 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2179 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2009 subscriberPropagate sub vals
2180 subscriberPropagate sub vals
2010− invalidateMyHeight = do
2011− invalidateMergeHeight' heightRef sub
2181+ invalidateMyHeight = invalidateMergeHeight' heightRef sub
2012 recalculateMyHeight = do
2182 recalculateMyHeight = do
2013 currentHeight <- readIORef heightRef
2183 currentHeight <- readIORef heightRef
2014 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?
2184 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?
@@ -2018,12 +2188,14 @@ mergeIntCheap d = Event $ \sub -> do
2018 LT -> return ()
2188 LT -> return ()
2019 EQ -> do
2189 EQ -> do
2020 let height = succHeight $ heightBagMax heights
2190 let height = succHeight $ heightBagMax heights
2021− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
2191+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2022 writeIORef heightRef $! height
2192 writeIORef heightRef $! height
2023 subscriberRecalculateHeight sub height
2193 subscriberRecalculateHeight sub height
2024 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2194 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2025 mySubscriber k = Subscriber
2195 mySubscriber k = Subscriber
2026 { subscriberPropagate = \a -> do
2196 { subscriberPropagate = \a -> do
2197+ checkCycle subscribed
2027 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2199 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2028 liftIO $ FastMutableIntMap.insert accum k a
2200 liftIO $ FastMutableIntMap.insert accum k a
2029 when wasEmpty scheduleSelf
2201 when wasEmpty scheduleSelf
@@ -2057,7 +2229,6 @@ mergeIntCheap d = Event $ \sub -> do
2057 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2229 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2058 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2230 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2059 return Nothing
2231 return Nothing
2060− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2061 defer $ SomeMergeInit $ do
2232 defer $ SomeMergeInit $ do
2062 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2233 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
@@ -2071,25 +2242,27 @@ mergeIntCheap d = Event $ \sub -> do
2071 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2242 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2072 liftIO $ for_ oldParents $ \oldParent -> do
2243 liftIO $ for_ oldParents $ \oldParent -> do
2073 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2244 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2246+ print ("updateMe", oldParentHeight)
2074 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2247 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2075 return $ IntMap.elems oldParents
2248 return $ IntMap.elems oldParents
2076− let s = Subscriber
2249+ let changeSubscriber = Subscriber
2077 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2250 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2078 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2251 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2079 defer $ updateMe a
2252 defer $ updateMe a
2080 , subscriberInvalidateHeight = \_ -> return ()
2253 , subscriberInvalidateHeight = \_ -> return ()
2081 , subscriberRecalculateHeight = \_ -> return ()
2254 , subscriberRecalculateHeight = \_ -> return ()
2083− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2256+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2084 forM_ change $ \c -> defer $ updateMe c
2257 forM_ change $ \c -> defer $ updateMe c
2085 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2258 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2086 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2259 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2087 -- its subscription.
2260 -- its subscription.
2088− liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2261+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2089 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2262 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2090− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2265+ return (EventSubscription unsubscribeAll subscribed, occ)
2094newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2267newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2095newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2268newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
@@ -2172,19 +2345,19 @@ runFrame a = SpiderHost $ do
2172 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2345 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2173 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2346 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2174 writeIORef vRef v
2347 writeIORef vRef v
2175− when debugInvalidate $ putStrLn $ "Invalidating Hold"
2348+ traceInvalidate $ "Invalidating Hold"
2176 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2349 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2177 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2350 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2178 writeIORef (eventEnvMergeUpdates env) []
2351 writeIORef (eventEnvMergeUpdates env) []
2179− when debugPropagate $ putStrLn "Updating merges"
2352+ tracePropagate (Proxy::Proxy x) $ "Updating merges"
2180 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2353 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2181− when debugPropagate $ putStrLn "Updating merges done"
2354+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"
2182 toReconnect <- readIORef toReconnectRef
2355 toReconnect <- readIORef toReconnectRef
2183 clearEventEnv env
2356 clearEventEnv env
2184 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2357 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2185 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2358 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2186 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2359 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2187− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2360+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2188 finalize wi
2361 finalize wi
2189 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2362 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2190 wi' <- mkWeakPtrWithDebug i "wi'"
2363 wi' <- mkWeakPtrWithDebug i "wi'"
@@ -2198,7 +2371,7 @@ runFrame a = SpiderHost $ do
2198 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2371 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2200 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2373 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2201− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2374+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2202 EventRoot _ -> "EventRoot"
2375 EventRoot _ -> "EventRoot"
2203 EventNever -> "EventNever"
2376 EventNever -> "EventNever"
2204 _ -> "something else"
2377 _ -> "something else"
@@ -2490,13 +2663,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline
2491 return result
2664 return result
2493−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2666+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2494 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2667 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2495 newFanEventWithTrigger f = SpiderHost $ do
2668 newFanEventWithTrigger f = SpiderHost $ do
2496 es <- newFanEventWithTriggerIO f
2669 es <- newFanEventWithTriggerIO f
2497 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2670 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2499−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2672+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2500 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2673 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2501 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2674 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2502 es <- newFanEventWithTriggerIO f
2675 es <- newFanEventWithTriggerIO f
@@ -2682,12 +2855,12 @@ instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2682 notReadyUntil _ = pure ()
2855 notReadyUntil _ = pure ()
2683 notReady = pure ()
2856 notReady = pure ()
2685−newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2858+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2686newEventWithTriggerIO f = do
2859newEventWithTriggerIO f = do
2687 es <- newFanEventWithTriggerIO $ \Refl -> f
2860 es <- newFanEventWithTriggerIO $ \Refl -> f
2688 return $ select es Refl
2861 return $ select es Refl
2690−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2863+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2691newFanEventWithTriggerIO f = do
2864newFanEventWithTriggerIO f = do
2692 occRef <- newIORef DMap.empty
2865 occRef <- newIORef DMap.empty
2693 subscribedRef <- newIORef DMap.empty
2866 subscribedRef <- newIORef DMap.empty
@@ -2728,4 +2901,4 @@ instance NotReady (SpiderTimeline x) (SpiderHost x) where
2729instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2902instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2730 notReadyUntil _ = return ()
2903 notReadyUntil _ = return ()
2731− notReady = return ()
2904+ notReady = return ()