@@ -99,30 +99,17 @@ withStackOneLine expr = unsafePerformIO $ do
102−debugPropagate :: Bool
104−debugInvalidateHeight :: Bool
106−debugInvalidate :: Bool
108#ifdef DEBUG
102#ifdef DEBUG
110#define DEBUG_NODEIDS
103#define DEBUG_NODEIDS
112−debugPropagate = True
114−debugInvalidateHeight = False
116−debugInvalidate = True
118class HasNodeId a where
105class HasNodeId a where
119 getNodeId :: a -> Int
106 getNodeId :: a -> Int
121−instance HasNodeId (Hold x p a) where
108+instance HasNodeId (Hold x p) where
122 getNodeId = holdNodeId
109 getNodeId = holdNodeId
124−instance HasNodeId (PushSubscribed x a b) where
111+-- instance HasNodeId (PushSubscribed x a b) where
125− getNodeId = pushSubscribedNodeId
112+-- getNodeId = pushSubscribedNodeId
127instance HasNodeId (SwitchSubscribed x a) where
114instance HasNodeId (SwitchSubscribed x a) where
128 getNodeId = switchSubscribedNodeId
115 getNodeId = switchSubscribedNodeId
@@ -143,41 +130,9 @@ instance HasNodeId (Pull x a) where
143showNodeId :: HasNodeId a => a -> String
130showNodeId :: HasNodeId a => a -> String
144showNodeId = ("#"<>) . show . getNodeId
131showNodeId = ("#"<>) . show . getNodeId
146−showSubscriberType :: Subscriber x a -> String
147−showSubscriberType = \case
148− SubscriberPush _ _ -> "SubscriberPush"
149− SubscriberMerge _ _ -> "SubscriberMerge"
150− SubscriberFan _ -> "SubscriberFan"
151− SubscriberMergeChange _ -> "SubscriberMergeChange"
152− SubscriberHold _ -> "SubscriberHold"
153− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
154− SubscriberSwitch _ -> "SubscriberSwitch"
155− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
156− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
157− SubscriberHandle -> "SubscriberHandle"
159−showEventType :: Event x a -> String
160−showEventType = \case
161− EventRoot _ _ -> "EventRoot"
162− EventNever -> "EventNever"
163− EventPush _ -> "EventPush"
164− EventMerge _ -> "EventMerge"
165− EventFan _ _ -> "EventFan"
166− EventSwitch _ -> "EventSwitch"
167− EventCoincidence _ -> "EventCoincidence"
168− EventHold _ -> "EventHold"
169− EventDyn _ -> "EventDyn"
170− EventHoldIdentity _ -> "EventHoldIdentity"
171− EventDynIdentity _ -> "EventDynIdentity"
175−debugPropagate = False
177−debugInvalidateHeight = False
179−debugInvalidate = False
181-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
136-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
182{-# INLINE showNodeId #-}
137{-# INLINE showNodeId #-}
183showNodeId :: a -> String
138showNodeId :: a -> String
@@ -363,7 +318,7 @@ wrap tag getSpecificSubscribed sub = do
363 let es = tag subd
318 let es = tag subd
364 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
319 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
366−eventRoot :: GCompare k => k a -> Root x k -> Event x a
321+eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
367eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
322eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
369eventNever :: Event x a
324eventNever :: Event x a
@@ -422,10 +377,10 @@ newSubscriberHold h = return $ Subscriber
424newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
379newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
425−newSubscriberFan subscribed = return $ Subscriber
380+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
426 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
381 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
427 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
382 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
428− tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
383+ -- tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
429 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
384 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
430 scheduleClear $ fanSubscribedOccurrence subscribed
385 scheduleClear $ fanSubscribedOccurrence subscribed
431 let f _ (Pair (Identity v) subsubs) = do
386 let f _ (Pair (Identity v) subsubs) = do
@@ -434,46 +389,37 @@ newSubscriberFan subscribed = return $ Subscriber
434 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
389 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
435 return ()
390 return ()
436 , subscriberInvalidateHeight = \old -> do
391 , subscriberInvalidateHeight = \old -> do
437− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
438 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
392 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
439 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
393 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
440− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
394+
441 , subscriberRecalculateHeight = \new -> do
395 , subscriberRecalculateHeight = \new -> do
442− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
443 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
396 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
444 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
397 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
445− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
448newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
400newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
449−newSubscriberSwitch subscribed = return $ Subscriber
401+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
450 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
402 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
451− tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
452 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
403 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
453 scheduleClear $ switchSubscribedOccurrence subscribed
404 scheduleClear $ switchSubscribedOccurrence subscribed
454 propagate a $ switchSubscribedSubscribers subscribed
405 propagate a $ switchSubscribedSubscribers subscribed
455 , subscriberInvalidateHeight = \_ -> do
406 , subscriberInvalidateHeight = \_ -> do
456− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
457 oldHeight <- readIORef $ switchSubscribedHeight subscribed
407 oldHeight <- readIORef $ switchSubscribedHeight subscribed
458 when (oldHeight /= invalidHeight) $ do
408 when (oldHeight /= invalidHeight) $ do
459 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
409 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
460 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
410 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
461− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
462− , subscriberRecalculateHeight = \new -> do
411+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
463− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
464− updateSwitchHeight new subscribed
465− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
468newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
414newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
469−newSubscriberCoincidenceOuter subscribed = return $ Subscriber
415+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
470 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
416 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
471− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
472 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
417 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
473 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
418 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
474 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
419 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
475 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
420 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
476 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
421 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
477 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
423 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
478 scheduleClear $ coincidenceSubscribedInnerParent subscribed
424 scheduleClear $ coincidenceSubscribedInnerParent subscribed
479 case occ of
425 case occ of
@@ -486,20 +432,13 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber
486 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
432 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
487 scheduleClear $ coincidenceSubscribedOccurrence subscribed
433 scheduleClear $ coincidenceSubscribedOccurrence subscribed
488 propagate o $ coincidenceSubscribedSubscribers subscribed
434 propagate o $ coincidenceSubscribedSubscribers subscribed
489− , subscriberInvalidateHeight = \_ -> do
490− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
491− invalidateCoincidenceHeight subscribed
435+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
492− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
493− , subscriberRecalculateHeight = \_ -> do
494− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
495− recalculateCoincidenceHeight subscribed
436+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
496− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
499newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
439newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
500−newSubscriberCoincidenceInner subscribed = return $ Subscriber
440+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber
501 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
441 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
502− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
503 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
442 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
504 case occ of
443 case occ of
505 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
444 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
@@ -507,14 +446,8 @@ newSubscriberCoincidenceInner subscribed = return $ Subscriber
507 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
446 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
508 scheduleClear $ coincidenceSubscribedOccurrence subscribed
447 scheduleClear $ coincidenceSubscribedOccurrence subscribed
509 propagate a $ coincidenceSubscribedSubscribers subscribed
448 propagate a $ coincidenceSubscribedSubscribers subscribed
510− , subscriberInvalidateHeight = \_ -> do
511− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
512− invalidateCoincidenceHeight subscribed
449+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
513− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
514− , subscriberRecalculateHeight = \_ -> do
515− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
516− recalculateCoincidenceHeight subscribed
450+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
517− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
520invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
453invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
@@ -524,15 +457,15 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
524recalculateSubscriberHeight = flip subscriberRecalculateHeight
457recalculateSubscriberHeight = flip subscriberRecalculateHeight
526-- | Propagate everything at the current height
459-- | Propagate everything at the current height
527−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
460+propagate :: forall a x. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
528−propagate a subscribers = withIncreasedDepth $ do
461+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
529 -- 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
462 -- 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
530 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
463 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
531 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
464 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
533-- | Propagate everything at the current height
466-- | Propagate everything at the current height
534−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
467+propagateFast :: forall a x. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
535−propagateFast a subscribers = withIncreasedDepth $ do
468+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
536 -- 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
469 -- 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
537 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
470 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
538 FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
471 FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
@@ -1004,7 +937,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
1004newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
937newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1006-- EventM can do everything BehaviorM can, plus create holds
939-- EventM can do everything BehaviorM can, plus create holds
1007−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
940+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1009newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
942newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
@@ -1279,45 +1212,87 @@ mkWeakPtrWithDebug x debugNote = do
1280type WeakList a = [Weak a]
1213type WeakList a = [Weak a]
1282−{-# INLINE withIncreasedDepth #-}
1215+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1283#ifdef DEBUG
1220#ifdef DEBUG
1222+debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1223+debugSubscriber description subscribed = return $ Subscriber
1225+ subscriberPropagate = \m -> do
1226+ tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1227+ subscriberPropagate subscribed m
1228+ , subscriberInvalidateHeight = \old -> do
1229+ putStrLn $ "invalidateSubscriberHeight: " <> description
1230+ subscriberInvalidateHeight subscribed old
1231+ putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"
1232+ , subscriberRecalculateHeight = \new -> do
1233+ putStrLn $ "subscriberRecalculateHeight: " <> description
1234+ subscriberRecalculateHeight subscribed new
1235+ putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"
1284−withIncreasedDepth :: CanTrace x m => m a -> m a
1239+{-# INLINE withIncreasedDepth #-}
1240+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1285−withIncreasedDepth a = do
1241+withIncreasedDepth _ a = do
1286− spiderTimeline <- askSpiderTimelineEnv
1287− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1242+ liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) succ
1288 result <- a
1243 result <- a
1289− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1244+ liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) pred
1290 return result
1245 return result
1292−withIncreasedDepth :: m a -> m a
1293−withIncreasedDepth = id
1296−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1298{-# INLINE tracePropagate #-}
1247{-# INLINE tracePropagate #-}
1299tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1248tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1300−tracePropagate p = traceWhen p debugPropagate
1249+tracePropagate p = trace p
1302{-# INLINE traceInvalidate #-}
1251{-# INLINE traceInvalidate #-}
1303traceInvalidate :: String -> IO ()
1252traceInvalidate :: String -> IO ()
1304−traceInvalidate = when debugInvalidate . liftIO . putStrLn
1253+traceInvalidate = liftIO . putStrLn
1306−{-# INLINE traceWhen #-}
1255+{-# INLINE trace #-}
1307−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1256+trace :: (CanTrace x m) => proxy x -> String -> m ()
1308−traceWhen p b message = traceMWhen p b $ return message
1257+trace p message = traceM p $ return message
1310−{-# INLINE traceMWhen #-}
1259+{-# INLINE traceM #-}
1311−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1260+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1312−traceMWhen _ b getMessage = when b $ do
1261+traceM _ getMessage = do
1313 message <- getMessage
1262 message <- getMessage
1315− spiderTimeline <- askSpiderTimelineEnv
1316− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1263+ d <- liftIO $ readIORef $ _spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)
1264+ liftIO $ putStrLn $ replicate d ' ' <> message
1268+{-# INLINE withIncreasedDepth #-}
1269+withIncreasedDepth :: forall x m proxy a. HasSpiderTimeline x => proxy x -> m a -> m a
1270+withIncreasedDepth _ = id
1272+{-# INLINE tracePropagate #-}
1273+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1274+tracePropagate _ _ = return ()
1276+{-# INLINE traceInvalidate #-}
1277+traceInvalidate :: String -> IO ()
1278+traceInvalidate _ = return ()
1280+{-# INLINE debugSubscriber #-}
1281+debugSubscriber :: HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1282+debugSubscriber _ = return
1284+{-# INLINE trace #-}
1285+trace :: (CanTrace x m) => proxy x -> String -> m ()
1286+trace _ _ = return ()
1288+{-# INLINE traceM #-}
1289+traceM :: (CanTrace x m) => proxy x -> m String -> m ()
1290+traceM _ _ = return ()
1320− liftIO $ putStrLn $ replicate d ' ' <> message
1293+
1322whoCreatedIORef :: IORef a -> IO [String]
1297whoCreatedIORef :: IORef a -> IO [String]
1323whoCreatedIORef (IORef a) = whoCreated $! a
1298whoCreatedIORef (IORef a) = whoCreated $! a
@@ -1339,14 +1314,16 @@ listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupB
1339{-# INLINE propagateSubscriberHold #-}
1314{-# INLINE propagateSubscriberHold #-}
1340propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1315propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1341propagateSubscriberHold h a = do
1316propagateSubscriberHold h a = do
1342− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1317+ traceM (Proxy :: Proxy x) $ liftIO $ do
1343 invalidators <- liftIO $ readIORef $ holdInvalidators h
1318 invalidators <- liftIO $ readIORef $ holdInvalidators h
1344 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1319 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1345 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1321 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1346 case {-# SCC "apply" #-} apply a v of
1322 case {-# SCC "apply" #-} apply a v of
1347 Nothing -> return ()
1323 Nothing -> return ()
1348 Just v' -> do
1324 Just v' -> do
1325+ withIncreasedDepth (Proxy :: Proxy x) $
1349− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1326+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1350 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1327 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1351 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1328 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1352 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1329 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1400,7 +1377,7 @@ getDynHold d = do
1400zeroRef :: IORef Height
1377zeroRef :: IORef Height
1401zeroRef = unsafePerformIO $ newIORef zeroHeight
1378zeroRef = unsafePerformIO $ newIORef zeroHeight
1403−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1380+getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1404getRootSubscribed k r sub = do
1381getRootSubscribed k r sub = do
1405 mSubscribed <- readIORef $ rootSubscribed r
1382 mSubscribed <- readIORef $ rootSubscribed r
1406 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1383 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
@@ -1414,7 +1391,9 @@ getRootSubscribed k r sub = do
1414 let !cached = rootSubscribed r
1391 let !cached = rootSubscribed r
1415 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1392 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1416 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1393 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1417− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1395+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1418 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1397 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1419 writeIORef uninitRef $! uninit
1398 writeIORef uninitRef $! uninit
1420 let !subscribed = RootSubscribed
1399 let !subscribed = RootSubscribed
@@ -1820,7 +1799,7 @@ revalidateMergeHeight m = do
1820 LT -> return ()
1799 LT -> return ()
1821 EQ -> do
1800 EQ -> do
1822 let height = succHeight $ heightBagMax heights
1801 let height = succHeight $ heightBagMax heights
1823− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1802+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
1824 writeIORef (_merge_heightRef m) $! height
1803 writeIORef (_merge_heightRef m) $! height
1825 subscriberRecalculateHeight (_merge_sub m) height
1804 subscriberRecalculateHeight (_merge_sub m) height
1826 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1805 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -1953,7 +1932,7 @@ mergeIntCheap d = Event $ \sub -> do
1953 LT -> return ()
1932 LT -> return ()
1954 EQ -> do
1933 EQ -> do
1955 let height = succHeight $ heightBagMax heights
1934 let height = succHeight $ heightBagMax heights
1956− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1935+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
1957 writeIORef heightRef $! height
1936 writeIORef heightRef $! height
1958 subscriberRecalculateHeight sub height
1937 subscriberRecalculateHeight sub height
1959 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1938 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
@@ -2105,19 +2084,19 @@ runFrame a = SpiderHost $ do
2105 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2084 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2106 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2085 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2107 writeIORef vRef v
2086 writeIORef vRef v
2108− when debugInvalidate $ putStrLn $ "Invalidating Hold"
2087+ traceInvalidate $ "Invalidating Hold"
2109 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2088 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2110 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2089 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2111 writeIORef (eventEnvMergeUpdates env) []
2090 writeIORef (eventEnvMergeUpdates env) []
2112− when debugPropagate $ putStrLn "Updating merges"
2091+ tracePropagate (Proxy::Proxy x) $ "Updating merges"
2113 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2092 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2114− when debugPropagate $ putStrLn "Updating merges done"
2093+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"
2115 toReconnect <- readIORef toReconnectRef
2094 toReconnect <- readIORef toReconnectRef
2116 clearEventEnv env
2095 clearEventEnv env
2117 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2096 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2118 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2097 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2119 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2098 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2120− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2099+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2121 finalize wi
2100 finalize wi
2122 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2101 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2123 wi' <- mkWeakPtrWithDebug i "wi'"
2102 wi' <- mkWeakPtrWithDebug i "wi'"
@@ -2421,13 +2400,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline
2422 return result
2401 return result
2424−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2403+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2425 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2404 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2426 newFanEventWithTrigger f = SpiderHost $ do
2405 newFanEventWithTrigger f = SpiderHost $ do
2427 es <- newFanEventWithTriggerIO f
2406 es <- newFanEventWithTriggerIO f
2428 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2407 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2430−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2409+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2431 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2410 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2432 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2411 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2433 es <- newFanEventWithTriggerIO f
2412 es <- newFanEventWithTriggerIO f
@@ -2599,12 +2578,12 @@ instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2599 notReadyUntil _ = pure ()
2578 notReadyUntil _ = pure ()
2600 notReady = pure ()
2579 notReady = pure ()
2602−newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2581+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2603newEventWithTriggerIO f = do
2582newEventWithTriggerIO f = do
2604 es <- newFanEventWithTriggerIO $ \Refl -> f
2583 es <- newFanEventWithTriggerIO $ \Refl -> f
2605 return $ select es Refl
2584 return $ select es Refl
2607−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2586+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2608newFanEventWithTriggerIO f = do
2587newFanEventWithTriggerIO f = do
2609 occRef <- newIORef DMap.empty
2588 occRef <- newIORef DMap.empty
2610 subscribedRef <- newIORef DMap.empty
2589 subscribedRef <- newIORef DMap.empty