@@ -9,6 +9,7 @@
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MultiWayIf #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RoleAnnotations #-}
14{-# LANGUAGE RoleAnnotations #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
@@ -19,7 +20,6 @@
19{-# LANGUAGE DeriveFunctor #-}
20{-# LANGUAGE DeriveFunctor #-}
20{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE InstanceSigs #-}
22{-# LANGUAGE InstanceSigs #-}
22−{-# LANGUAGE MultiWayIf #-}
24#ifdef USE_REFLEX_OPTIMIZER
24#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -38,17 +38,15 @@ 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_)
41import Control.Monad.Reader.Class
42import Control.Monad.Reader.Class
42import Control.Monad.IO.Class
43import Control.Monad.IO.Class
43import Control.Monad.ReaderIO
44import Control.Monad.ReaderIO
44import Control.Monad.Ref
45import Control.Monad.Ref
45−import Control.Monad.Fail (MonadFail)
46−import qualified Control.Monad.Fail as MonadFail
47import Data.Align
46import Data.Align
48import Data.Coerce
47import Data.Coerce
49−import Data.Dependent.Map (DMap)
48+import Data.Dependent.Map (DMap, DSum (..))
50import qualified Data.Dependent.Map as DMap
49import qualified Data.Dependent.Map as DMap
51−import Data.Dependent.Sum (DSum (..))
52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
50import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
53import qualified Data.FastMutableIntMap as FastMutableIntMap
51import qualified Data.FastMutableIntMap as FastMutableIntMap
54import Data.Foldable hiding (concat, elem, sequence_)
52import Data.Foldable hiding (concat, elem, sequence_)
@@ -61,11 +59,10 @@ import qualified Data.IntMap.Strict as IntMap
61import Data.IORef
59import Data.IORef
62import Data.Kind (Type)
60import Data.Kind (Type)
63import Data.Maybe hiding (mapMaybe)
61import Data.Maybe hiding (mapMaybe)
64−import Data.Monoid (mempty, (<>))
62+import Data.Monoid ((<>))
65import Data.Proxy
63import Data.Proxy
66import Data.These
64import Data.These
67import Data.Traversable
65import Data.Traversable
68−import Data.Type.Equality ((:~:)(Refl))
69import Data.Witherable (Filterable, mapMaybe)
66import Data.Witherable (Filterable, mapMaybe)
70import GHC.Exts hiding (toList)
67import GHC.Exts hiding (toList)
71import GHC.IORef (IORef (..))
68import GHC.IORef (IORef (..))
@@ -75,23 +72,19 @@ import System.IO.Unsafe
75import System.Mem.Weak
72import System.Mem.Weak
76import Unsafe.Coerce
73import Unsafe.Coerce
78−#ifdef MIN_VERSION_semialign
75+#if defined(MIN_VERSION_semialign)
79#if MIN_VERSION_these(0,8,0)
76#if MIN_VERSION_these(0,8,0)
80import Data.These.Combinators (justThese)
77import Data.These.Combinators (justThese)
82−#if MIN_VERSION_semialign(1,1,0)
83−import Data.Zip (Zip (..))
87#ifdef DEBUG_CYCLES
81#ifdef DEBUG_CYCLES
88import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
82import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
91import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
83import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
92import qualified Data.List.NonEmpty as NonEmpty
84import qualified Data.List.NonEmpty as NonEmpty
85+import Data.Monoid (mempty)
93import Data.Tree (Forest, Tree (..), drawForest)
86import Data.Tree (Forest, Tree (..), drawForest)
94−import Data.List (isPrefixOf)
87+#endif
96import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
89import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
97import qualified Data.FastWeakBag as FastWeakBag
90import qualified Data.FastWeakBag as FastWeakBag
@@ -106,65 +99,28 @@ import qualified Reflex.Class
106import qualified Reflex.Class as R
99import qualified Reflex.Class as R
107import qualified Reflex.Host.Class
100import qualified Reflex.Host.Class
108import Reflex.NotReady.Class
101import Reflex.NotReady.Class
109−import Data.Patch
102+import Reflex.Patch
110−import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
103+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
111−import Reflex.PerformEvent.Base (PerformEventT)
113#ifdef DEBUG_TRACE_EVENTS
105#ifdef DEBUG_TRACE_EVENTS
114import qualified Data.ByteString.Char8 as BS8
106import qualified Data.ByteString.Char8 as BS8
115import System.IO (stderr)
107import System.IO (stderr)
116import Data.List (isPrefixOf)
108import Data.List (isPrefixOf)
119−-- TODO stdout might not be the best channel for debug output
120−debugStrLn :: String -> IO ()
121−debugStrLn = putStrLn
123−#ifdef DEBUG_TRACE_EVENTS
124withStackOneLine :: (BS8.ByteString -> a) -> a
110withStackOneLine :: (BS8.ByteString -> a) -> a
125withStackOneLine expr = unsafePerformIO $ do
111withStackOneLine expr = unsafePerformIO $ do
126 stack <- currentCallStack
112 stack <- currentCallStack
127 return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
113 return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
128− where dropInternal = filterStack "Reflex.Spider.Internal"
114+ where dropInternal = filter (not . isPrefixOf "Reflex.Spider.Internal")
132−debugPropagate :: Bool
134−debugInvalidateHeight :: Bool
136−debugInvalidate :: Bool
138#ifdef DEBUG
118#ifdef DEBUG
139#define DEBUG_NODEIDS
119#define DEBUG_NODEIDS
141−#ifdef DEBUG_TRACE_PROPAGATION
142−debugPropagate = True
144−debugPropagate = False
147−#ifdef DEBUG_TRACE_HEIGHT
148−debugInvalidateHeight = True
150−debugInvalidateHeight = False
153−#ifdef DEBUG_TRACE_INVALIDATION
154−debugInvalidate = True
156−debugInvalidate = False
159class HasNodeId a where
121class HasNodeId a where
160 getNodeId :: a -> Int
122 getNodeId :: a -> Int
162−instance HasNodeId (CacheSubscribed x a) where
163− getNodeId = _cacheSubscribed_nodeId
165−instance HasNodeId (FanInt x a) where
166− getNodeId = _fanInt_nodeId
168instance HasNodeId (Hold x p) where
124instance HasNodeId (Hold x p) where
169 getNodeId = holdNodeId
125 getNodeId = holdNodeId
@@ -185,27 +141,16 @@ instance HasNodeId (Pull x a) where
186{-# INLINE showNodeId #-}
142{-# INLINE showNodeId #-}
187showNodeId :: HasNodeId a => a -> String
143showNodeId :: HasNodeId a => a -> String
188−showNodeId = showNodeId' . getNodeId
144+showNodeId = ("#"<>) . show . getNodeId
190−showNodeId' :: Int -> String
191−showNodeId' = ("#"<>) . show
196−debugPropagate = False
197−debugInvalidateHeight = False
198−debugInvalidate = False
200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
149-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
201{-# INLINE showNodeId #-}
150{-# INLINE showNodeId #-}
202showNodeId :: a -> String
151showNodeId :: a -> String
203showNodeId _ = ""
152showNodeId _ = ""
205−{-# INLINE showNodeId' #-}
206−showNodeId' :: Int -> String
211#ifdef DEBUG_NODEIDS
156#ifdef DEBUG_NODEIDS
@@ -251,9 +196,9 @@ subscribeAndRead = unEvent
251-- caching; if the computation function is very cheap, this is (much) more
196-- caching; if the computation function is very cheap, this is (much) more
252-- efficient than 'push'
197-- efficient than 'push'
253{-# INLINE [1] pushCheap #-}
198{-# INLINE [1] pushCheap #-}
254−pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
199+pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
255pushCheap !f e = Event $ \sub -> do
200pushCheap !f e = Event $ \sub -> do
256− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
201+ (subscription, occ) <- subscribeAndRead e $ sub
257 { subscriberPropagate = \a -> do
202 { subscriberPropagate = \a -> do
258 mb <- f a
203 mb <- f a
259 mapM_ (subscriberPropagate sub) mb
204 mapM_ (subscriberPropagate sub) mb
@@ -272,10 +217,10 @@ terminalSubscriber p = Subscriber
273-- | Subscribe to an Event only for the duration of one occurrence
218-- | Subscribe to an Event only for the duration of one occurrence
274{-# INLINE subscribeAndReadHead #-}
219{-# INLINE subscribeAndReadHead #-}
275−subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
220+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
276subscribeAndReadHead e sub = do
221subscribeAndReadHead e sub = do
277 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
222 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
278− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub
223+ (subscription, occ) <- subscribeAndRead e $ sub
279 { subscriberPropagate = \a -> do
224 { subscriberPropagate = \a -> do
280 liftIO $ unsubscribe =<< readIORef subscriptionRef
225 liftIO $ unsubscribe =<< readIORef subscriptionRef
281 subscriberPropagate sub a
226 subscriberPropagate sub a
@@ -286,42 +231,24 @@ subscribeAndReadHead e sub = do
286 return (subscription, occ)
231 return (subscription, occ)
288--TODO: Make this lazy in its input event
233--TODO: Make this lazy in its input event
289−headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)
234+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
290headE originalE = do
235headE originalE = do
291 parent <- liftIO $ newIORef $ Just originalE
236 parent <- liftIO $ newIORef $ Just originalE
292 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
237 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
293 let clearParent = liftIO $ writeIORef parent Nothing
238 let clearParent = liftIO $ writeIORef parent Nothing
294− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
239+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
295 when (isJust occ) clearParent
240 when (isJust occ) clearParent
296− return $ Event $ \sub ->
241+ return $ Event $ \sub -> do
297 liftIO (readIORef parent) >>= \case
242 liftIO (readIORef parent) >>= \case
298− Nothing -> subscribeAndReadNever
243+ Nothing -> subscribeAndReadNever
299 Just e -> subscribeAndReadHead e sub
244 Just e -> subscribeAndReadHead e sub
301data CacheSubscribed x a
246data CacheSubscribed x a
302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
247 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
248 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
249 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
306− , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int
310−nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())
314−now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x
317− nowOrNot <- liftIO $ newIORef $ Just ()
318− scheduleClear nowOrNot
319− return . Event $ \_ -> do
320− occ <- liftIO . readIORef $ nowOrNot
321− return ( EventSubscription (return ()) eventSubscribedNow
325-- | Construct an 'Event' whose value is guaranteed not to be recomputed
252-- | Construct an 'Event' whose value is guaranteed not to be recomputed
326-- repeatedly
253-- repeatedly
@@ -346,23 +273,16 @@ cacheEvent e =
346 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
273 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
347 Just subscribedTicket -> return subscribedTicket
274 Just subscribedTicket -> return subscribedTicket
348 Nothing -> do
275 Nothing -> do
350− nodeId <- liftIO newNodeId
352 subscribers <- liftIO FastWeakBag.empty
276 subscribers <- liftIO FastWeakBag.empty
353 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
277 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
355− (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber
357 (parentSub, occ) <- subscribeAndRead e $ Subscriber
278 (parentSub, occ) <- subscribeAndRead e $ Subscriber
359− { subscriberPropagate = \a -> do
279+ { subscriberPropagate = \a -> do
360− liftIO $ writeIORef occRef (Just a)
280+ liftIO $ writeIORef occRef (Just a)
361− scheduleClear occRef
281+ scheduleClear occRef
362− propagateFast a subscribers
282+ propagateFast a subscribers
363− , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight
283+ , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight
364− , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight
284+ , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight
366 when (isJust occ) $ do
286 when (isJust occ) $ do
367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
287 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
368 scheduleClear occRef
288 scheduleClear occRef
@@ -370,22 +290,19 @@ cacheEvent e =
370 { _cacheSubscribed_subscribers = subscribers
290 { _cacheSubscribed_subscribers = subscribers
371 , _cacheSubscribed_parent = parentSub
291 , _cacheSubscribed_parent = parentSub
372 , _cacheSubscribed_occurrence = occRef
292 , _cacheSubscribed_occurrence = occRef
374− , _cacheSubscribed_nodeId = nodeId
377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
294 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
295 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
379 return subscribedTicket
296 return subscribedTicket
380 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
297 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
382−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
299+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
383 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
300 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
384−cacheSubscription sub mSubscribedRef subscribedTicket = do
301+cacheSubscription sub mSubscribedRef subscribedTicket = do
385 subscribed <- getFastWeakTicketValue subscribedTicket
302 subscribed <- getFastWeakTicketValue subscribedTicket
386 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
303 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
387 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
304 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
389 let parentSub = _cacheSubscribed_parent subscribed
306 let parentSub = _cacheSubscribed_parent subscribed
390 es = EventSubscription
307 es = EventSubscription
391 { _eventSubscription_unsubscribe = do
308 { _eventSubscription_unsubscribe = do
@@ -404,9 +321,9 @@ cacheSubscription sub mSubscribedRef subscribedTicket = do
404 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
321 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
405 , eventSubscribedHasOwnHeightRef = False
322 , eventSubscribedHasOwnHeightRef = False
406 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
323 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
410 return (es, occ)
327 return (es, occ)
@@ -464,6 +381,16 @@ data Subscriber x a = Subscriber
464 , subscriberRecalculateHeight :: !(Height -> IO ())
381 , subscriberRecalculateHeight :: !(Height -> IO ())
384+--TODO: Move this comment to WeakBag
385+-- These function are constructor functions that are marked NOINLINE so they are
386+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
387+-- so any weak references that are attached to the constructors will have their
388+-- finalizer run. Using the opaque constructor, does not see the
389+-- constructor application, so it behaves like an IORef and cannot be fused away.
391+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
392+-- the weak pointer to it in some cases.
467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
394newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
468newSubscriberHold h = return $ Subscriber
395newSubscriberHold h = return $ Subscriber
469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
396 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
@@ -485,12 +412,14 @@ newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId su
485 return ()
412 return ()
486 , subscriberInvalidateHeight = \old -> do
413 , subscriberInvalidateHeight = \old -> do
487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
414 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
488− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
415+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
489 , subscriberRecalculateHeight = \new -> do
417 , subscriberRecalculateHeight = \new -> do
490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
418 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
491− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
419+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
423newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
495newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
424newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
425 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
@@ -501,7 +430,7 @@ newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <
501 oldHeight <- readIORef $ switchSubscribedHeight subscribed
430 oldHeight <- readIORef $ switchSubscribedHeight subscribed
502 when (oldHeight /= invalidHeight) $ do
431 when (oldHeight /= invalidHeight) $ do
503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
432 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
504− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
433+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
505 , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
434 , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
@@ -517,17 +446,17 @@ newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoinciden
517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
446 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
518 scheduleClear $ coincidenceSubscribedInnerParent subscribed
447 scheduleClear $ coincidenceSubscribedInnerParent subscribed
519 case occ of
448 case occ of
520− Nothing ->
449+ Nothing -> do
521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
450 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
451 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
523− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
452+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
524− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
453+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
525 Just o -> do -- Since it's already firing, no need to adjust height
454 Just o -> do -- Since it's already firing, no need to adjust height
526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
455 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
527 scheduleClear $ coincidenceSubscribedOccurrence subscribed
456 scheduleClear $ coincidenceSubscribedOccurrence subscribed
528 propagate o $ coincidenceSubscribedSubscribers subscribed
457 propagate o $ coincidenceSubscribedSubscribers subscribed
529 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
458 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
530− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
459+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
462newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
@@ -551,18 +480,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
551recalculateSubscriberHeight = flip subscriberRecalculateHeight
480recalculateSubscriberHeight = flip subscriberRecalculateHeight
553-- | Propagate everything at the current height
482-- | Propagate everything at the current height
554−propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
483+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
555−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
484+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
556 -- 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
485 -- 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
557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
486 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
558− WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
487+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
560-- | Propagate everything at the current height
489-- | Propagate everything at the current height
561−propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
490+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
562−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
491+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
563 -- 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
492 -- 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
564 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
493 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
565− FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
494+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
567--------------------------------------------------------------------------------
496--------------------------------------------------------------------------------
568-- EventSubscribed
497-- EventSubscribed
@@ -607,16 +536,6 @@ eventSubscribedNever = EventSubscribed
607 , eventSubscribedWhoCreated = return ["never"]
536 , eventSubscribedWhoCreated = return ["never"]
610−eventSubscribedNow :: EventSubscribed x
611−eventSubscribedNow = EventSubscribed
612− { eventSubscribedHeightRef = zeroRef
613− , eventSubscribedRetained = toAny ()
615− , eventSubscribedGetParents = return []
616− , eventSubscribedHasOwnHeightRef = False
617− , eventSubscribedWhoCreated = return ["now"]
621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
540eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
622eventSubscribedFan !subscribed = EventSubscribed
541eventSubscribedFan !subscribed = EventSubscribed
@@ -994,10 +913,8 @@ instance Monad (BehaviorM x) where
994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
913 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
995 {-# INLINE return #-}
914 {-# INLINE return #-}
996 return x = BehaviorM $ return x
915 return x = BehaviorM $ return x
997−#if !MIN_VERSION_base(4,13,0)
998 {-# INLINE fail #-}
916 {-# INLINE fail #-}
999 fail s = BehaviorM $ fail s
917 fail s = BehaviorM $ fail s
1002data BehaviorSubscribed x a
919data BehaviorSubscribed x a
1003 = forall p. BehaviorSubscribedHold (Hold x p)
920 = forall p. BehaviorSubscribedHold (Hold x p)
@@ -1057,7 +974,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
1057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
974newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1059-- EventM can do everything BehaviorM can, plus create holds
976-- EventM can do everything BehaviorM can, plus create holds
1060−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
977+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
979newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
@@ -1082,8 +999,7 @@ heightBagFromList :: [Height] -> HeightBag
1082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
999heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1084heightBagAdd :: Height -> HeightBag -> HeightBag
1001heightBagAdd :: Height -> HeightBag -> HeightBag
1085−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1002+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1086− IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1088heightBagRemove :: Height -> HeightBag -> HeightBag
1004heightBagRemove :: Height -> HeightBag -> HeightBag
1089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1005heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
@@ -1092,13 +1008,6 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo
1092 0 -> IntMap.delete h c
1008 0 -> IntMap.delete h c
1093 _ -> IntMap.insert h (pred old) c
1009 _ -> IntMap.insert h (pred old) c
1095−heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag
1096−heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
1097− removed old = HeightBag (pred s) $ case old of
1098− 0 -> IntMap.delete h c
1099− _ -> IntMap.insert h (pred old) c
1102heightBagMax :: HeightBag -> Height
1011heightBagMax :: HeightBag -> Height
1103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1012heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1104 Just ((h, _), _) -> Height h
1013 Just ((h, _), _) -> Height h
@@ -1199,10 +1108,7 @@ instance HasSpiderTimeline x => Semialign (Event x) where
1199 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1108 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1200 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1109 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1202−#ifdef MIN_VERSION_semialign
1111+#if defined(MIN_VERSION_semialign)
1203−#if MIN_VERSION_semialign(1,1,0)
1204−instance HasSpiderTimeline x => Zip (Event x) where
1206 zip x y = mapMaybe justThese $ align x y
1112 zip x y = mapMaybe justThese $ align x y
@@ -1346,7 +1252,7 @@ mkWeakPtrWithDebug x debugNote = do
1346 x' <- evaluate x
1252 x' <- evaluate x
1347 mkWeakPtr x' $
1253 mkWeakPtr x' $
1348 if debugFinalize
1254 if debugFinalize
1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote
1255+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1350 else Nothing
1256 else Nothing
1352type WeakList a = [Weak a]
1258type WeakList a = [Weak a]
@@ -1359,22 +1265,19 @@ type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1359#ifdef DEBUG
1265#ifdef DEBUG
1361debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1267debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1362−debugSubscriber description = return . debugSubscriber' description
1268+debugSubscriber description subscribed = return $ Subscriber
1364−debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a
1365−debugSubscriber' description subscribed = Subscriber
1367 subscriberPropagate = \m -> do
1270 subscriberPropagate = \m -> do
1368 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1271 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1369 subscriberPropagate subscribed m
1272 subscriberPropagate subscribed m
1370 , subscriberInvalidateHeight = \old -> do
1273 , subscriberInvalidateHeight = \old -> do
1371− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1274+ putStrLn $ "invalidateSubscriberHeight: " <> description
1372 subscriberInvalidateHeight subscribed old
1275 subscriberInvalidateHeight subscribed old
1373− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
1276+ putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"
1374 , subscriberRecalculateHeight = \new -> do
1277 , subscriberRecalculateHeight = \new -> do
1375− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1278+ putStrLn $ "subscriberRecalculateHeight: " <> description
1376 subscriberRecalculateHeight subscribed new
1279 subscriberRecalculateHeight subscribed new
1377− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
1280+ putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"
@@ -1388,15 +1291,11 @@ withIncreasedDepth _ a = do
1389{-# INLINE tracePropagate #-}
1292{-# INLINE tracePropagate #-}
1390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1293tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1391−tracePropagate p = when debugPropagate . trace p
1294+tracePropagate p = trace p
1393{-# INLINE traceInvalidate #-}
1296{-# INLINE traceInvalidate #-}
1394traceInvalidate :: String -> IO ()
1297traceInvalidate :: String -> IO ()
1395−traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1298+traceInvalidate = liftIO . putStrLn
1397−{-# INLINE traceInvalidateHeight #-}
1398−traceInvalidateHeight :: String -> IO ()
1399−traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1401{-# INLINE trace #-}
1300{-# INLINE trace #-}
1402trace :: (CanTrace x m) => proxy x -> String -> m ()
1301trace :: (CanTrace x m) => proxy x -> String -> m ()
@@ -1407,7 +1306,7 @@ traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1407traceM _ getMessage = do
1306traceM _ getMessage = do
1408 message <- getMessage
1307 message <- getMessage
1409 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1308 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1410− liftIO $ debugStrLn $ replicate d ' ' <> message
1309+ liftIO $ putStrLn $ replicate d ' ' <> message
@@ -1423,20 +1322,10 @@ tracePropagate _ _ = return ()
1423traceInvalidate :: String -> IO ()
1322traceInvalidate :: String -> IO ()
1424traceInvalidate _ = return ()
1323traceInvalidate _ = return ()
1426−{-# INLINE traceInvalidateHeight #-}
1427−traceInvalidateHeight :: String -> IO ()
1428−traceInvalidateHeight _ = return ()
1430{-# INLINE debugSubscriber #-}
1325{-# INLINE debugSubscriber #-}
1431debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1326debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1432debugSubscriber _ = return
1327debugSubscriber _ = return
1434−{-# INLINE debugSubscriber' #-}
1435−debugSubscriber' :: String -> Subscriber x a -> Subscriber x a
1436−debugSubscriber' _ = id
1440{-# INLINE trace #-}
1329{-# INLINE trace #-}
1441trace :: (CanTrace x m) => proxy x -> String -> m ()
1330trace :: (CanTrace x m) => proxy x -> String -> m ()
1442trace _ _ = return ()
1331trace _ _ = return ()
@@ -1447,9 +1336,18 @@ traceM _ _ = return ()
1450whoCreatedIORef :: IORef a -> IO [String]
1340whoCreatedIORef :: IORef a -> IO [String]
1451whoCreatedIORef (IORef a) = whoCreated $! a
1341whoCreatedIORef (IORef a) = whoCreated $! a
1345+data EventLoopException = EventLoopException (Forest String)
1346+instance Exception EventLoopException
1348+instance Show EventLoopException where
1349+ show (EventLoopException stacks) = "Causality loop detected:\n" <> drawForest stacks
1453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1351groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1454groupByHead = \case
1352groupByHead = \case
1455 [] -> []
1353 [] -> []
@@ -1460,28 +1358,7 @@ groupByHead = \case
1460 | otherwise -> (x, xs :| []) : l
1358 | otherwise -> (x, xs :| []) : l
1462listsToForest :: Eq a => [[a]] -> Forest a
1360listsToForest :: Eq a => [[a]] -> Forest a
1463−listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)
1361+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1464− where buildForest (a, lists') = Node a $ listsToForest $ toList lists'
1466−showStacks :: [[String]] -> String
1467−showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1469−filterStack :: String -> [String] -> [String]
1470−#ifdef DEBUG_HIDE_INTERNALS
1471−filterStack prefix = filter (not . (prefix `isPrefixOf`))
1473−filterStack prefix = id
1478−data EventLoopException = EventLoopException [[String]]
1479−instance Exception EventLoopException
1481−instance Show EventLoopException where
1482− show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1483− then "no location information, compile with profiling enabled for stack tree"
1484− else showStacks stacks
@@ -1489,8 +1366,8 @@ data EventLoopException = EventLoopException
1489instance Exception EventLoopException
1366instance Exception EventLoopException
1491instance Show EventLoopException where
1368instance Show EventLoopException where
1492− show EventLoopException = "causality loop detected: \n" <>
1369+ show EventLoopException = "Causality loop detected: \n" <>
1493− "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"
1370+ "no location information, compile with --enable-profiling and reflex with flag 'debug-cycles'"
@@ -1498,7 +1375,7 @@ instance Show EventLoopException where
1498{-# INLINE propagateSubscriberHold #-}
1375{-# INLINE propagateSubscriberHold #-}
1499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1376propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1500propagateSubscriberHold h a = do
1377propagateSubscriberHold h a = do
1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1378+ traceM (Proxy :: Proxy x) $ liftIO $ do
1502 invalidators <- liftIO $ readIORef $ holdInvalidators h
1379 invalidators <- liftIO $ readIORef $ holdInvalidators h
1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1380 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
@@ -1506,7 +1383,7 @@ propagateSubscriberHold h a = do
1506 case {-# SCC "apply" #-} apply a v of
1383 case {-# SCC "apply" #-} apply a v of
1507 Nothing -> return ()
1384 Nothing -> return ()
1508 Just v' -> do
1385 Just v' -> do
1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1386+ withIncreasedDepth (Proxy :: Proxy x) $
1510 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1387 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1388 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1389 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
@@ -1627,9 +1504,6 @@ data FanInt x a = FanInt
1627 { _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
1504 { _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
1628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1505 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1506 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1630−#ifdef DEBUG_NODEIDS
1631− , _fanInt_nodeId :: {-# UNPACK #-} !Int
1635newFanInt :: IO (FanInt x a)
1509newFanInt :: IO (FanInt x a)
@@ -1637,16 +1511,10 @@ newFanInt = do
1637 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
1511 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
1638 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1512 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1639 occRef <- newIORef $ error "fanInt: no occurrence"
1513 occRef <- newIORef $ error "fanInt: no occurrence"
1640−#ifdef DEBUG_NODEIDS
1641− nodeId <- newNodeId
1643 return $ FanInt
1514 return $ FanInt
1644 { _fanInt_subscribers = subscribers
1515 { _fanInt_subscribers = subscribers
1645 , _fanInt_subscriptionRef = subscriptionRef
1516 , _fanInt_subscriptionRef = subscriptionRef
1646 , _fanInt_occRef = occRef
1517 , _fanInt_occRef = occRef
1647−#ifdef DEBUG_NODEIDS
1648− , _fanInt_nodeId = nodeId
1652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1520fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
@@ -1655,21 +1523,20 @@ fanInt p = unsafePerformIO $ do
1655 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1523 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1524 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1657 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1525 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1658− let desc = "fanInt" <> showNodeId self <> ", k = " <> show k
1659− (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber
1526+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1660 { subscriberPropagate = \m -> do
1527 { subscriberPropagate = \m -> do
1661 liftIO $ writeIORef (_fanInt_occRef self) m
1528 liftIO $ writeIORef (_fanInt_occRef self) m
1662 scheduleIntClear $ _fanInt_occRef self
1529 scheduleIntClear $ _fanInt_occRef self
1663 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1530 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1664− FastWeakBag.traverse_ b $ \s ->
1531+ FastWeakBag.traverse b $ \s ->
1665 subscriberPropagate s v
1532 subscriberPropagate s v
1666− , subscriberInvalidateHeight = \old ->
1533+ , subscriberInvalidateHeight = \old ->
1667− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1534+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1668− FastWeakBag.traverse_ b $ \s ->
1535+ FastWeakBag.traverse b $ \s ->
1669 subscriberInvalidateHeight s old
1536 subscriberInvalidateHeight s old
1670 , subscriberRecalculateHeight = \new ->
1537 , subscriberRecalculateHeight = \new ->
1671− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1538+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1672− FastWeakBag.traverse_ b $ \s ->
1539+ FastWeakBag.traverse b $ \s ->
1673 subscriberRecalculateHeight s new
1540 subscriberRecalculateHeight s new
1675 liftIO $ do
1542 liftIO $ do
@@ -1685,14 +1552,14 @@ fanInt p = unsafePerformIO $ do
1685 Just b -> return b
1552 Just b -> return b
1686 ticket <- liftIO $ FastWeakBag.insert sub b
1553 ticket <- liftIO $ FastWeakBag.insert sub b
1687 currentOcc <- readIORef (_fanInt_occRef self)
1554 currentOcc <- readIORef (_fanInt_occRef self)
1689 subscribed <- fanIntSubscribed ticket self
1556 subscribed <- fanIntSubscribed ticket self
1690 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1557 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1692fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1559fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1693−fanIntSubscribed ticket self = do
1560+fanIntSubscribed ticket self = do
1694 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1561 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1695− return $ EventSubscribed
1562+ return $ EventSubscribed
1696 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1563 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1697 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1564 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1698#ifdef DEBUG_CYCLES
1565#ifdef DEBUG_CYCLES
@@ -1701,7 +1568,7 @@ fanIntSubscribed ticket self = do
1701 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1568 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1706{-# INLINABLE getFanSubscribed #-}
1573{-# INLINABLE getFanSubscribed #-}
1707getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1574getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
@@ -1914,7 +1781,7 @@ mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updat
1914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1781 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1782 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1916 forM_ mOldSubd $ \oldSubd -> do
1783 forM_ mOldSubd $ \oldSubd -> do
1917− oldHeight <- liftIO $ getEventSubscribedHeight $
1784+ oldHeight <- liftIO $ getEventSubscribedHeight $
1918 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1785 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1787 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
@@ -1960,7 +1827,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
1960 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1827 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1828 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1962 Nothing -> do
1829 Nothing -> do
1963− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1830+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1964 _mergeSubscribedParentWithMove_subscription parent
1831 _mergeSubscribedParentWithMove_subscription parent
1966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1833 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
@@ -1968,7 +1835,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
1968 Just toKey -> do
1835 Just toKey -> do
1969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1836 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1970 return Nothing
1837 return Nothing
1971− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1838+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1972 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1839 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1974 return (toDelete, applyAlways p' oldParents)
1841 return (toDelete, applyAlways p' oldParents)
@@ -2021,16 +1888,16 @@ invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
2021invalidateMergeHeight' heightRef sub = do
1888invalidateMergeHeight' heightRef sub = do
2022 oldHeight <- readIORef heightRef
1889 oldHeight <- readIORef heightRef
2023 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1890 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
2024− when (oldHeight /= invalidHeight) $ do
1891+ when (oldHeight /= invalidHeight) $ do
2025 writeIORef heightRef $! invalidHeight
1892 writeIORef heightRef $! invalidHeight
2026 subscriberInvalidateHeight sub oldHeight
1893 subscriberInvalidateHeight sub oldHeight
2028revalidateMergeHeight :: Merge x k v s -> IO ()
1895revalidateMergeHeight :: Merge x k v s -> IO ()
2029revalidateMergeHeight m = do
1896revalidateMergeHeight m = do
2030 currentHeight <- readIORef $ _merge_heightRef m
1897 currentHeight <- readIORef $ _merge_heightRef m
2032 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1899 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
2033− when (currentHeight == invalidHeight) $ do
1900+ when (currentHeight == invalidHeight) $ do
2034 heights <- readIORef $ _merge_heightBagRef m
1901 heights <- readIORef $ _merge_heightBagRef m
2035 parents <- readIORef $ _merge_parentsRef m
1902 parents <- readIORef $ _merge_parentsRef m
2036 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1903 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -2038,7 +1905,7 @@ revalidateMergeHeight m = do
2038 LT -> return ()
1905 LT -> return ()
2039 EQ -> do
1906 EQ -> do
2040 let height = succHeight $ heightBagMax heights
1907 let height = succHeight $ heightBagMax heights
2041− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1908+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2042 writeIORef (_merge_heightRef m) $! height
1909 writeIORef (_merge_heightRef m) $! height
2043 subscriberRecalculateHeight (_merge_sub m) height
1910 subscriberRecalculateHeight (_merge_sub m) height
2044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1911 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -2046,35 +1913,32 @@ revalidateMergeHeight m = do
2046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1913scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
2047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1914scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
2048 vals <- liftIO $ readIORef $ _merge_accumRef m
1915 vals <- liftIO $ readIORef $ _merge_accumRef m
2049− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
1916+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
2050 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1917 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
2051− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
1918+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
2052 --TODO: Assert that m is not empty
1919 --TODO: Assert that m is not empty
2053 subscriberPropagate (_merge_sub m) vals
1920 subscriberPropagate (_merge_sub m) vals
2055−checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()
1922+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> Height -> EventM x ()
2056−checkCycle subscribed = liftIO $ do
1923+checkCycle subscribed height = do
2057− height <- readIORef (eventSubscribedHeightRef subscribed)
2059− -- currentHeight <- getCurrentHeight
1924+ currentHeight <- getCurrentHeight
2060− -- when (height <= currentHeight) $ if height /= invalidHeight
1925+ when (height <= currentHeight) $ if height /= invalidHeight
2061− -- then do
1926+ then do
2062− -- myStack <- liftIO $ whoCreatedIORef undefined --TODO
1927+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
2063− -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1928+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
2064− -- else liftIO $
1929+ else liftIO $
2065− when (height == invalidHeight) $
2066#ifdef DEBUG_CYCLES
1930#ifdef DEBUG_CYCLES
2068− nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
1932+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
2069− stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
1933+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
2070− throwIO (EventLoopException stacks)
1934+ throwIO (EventLoopException (listsToForest stacks))
2072− throwIO EventLoopException
1936+ throwIO EventLoopException
2076−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)
1940+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
2077−mergeSubscriber subscribed m getKey = Subscriber
1941+mergeSubscriber m getKey = Subscriber
2078 { subscriberPropagate = \a -> do
1942 { subscriberPropagate = \a -> do
2079 oldM <- liftIO $ readIORef $ _merge_accumRef m
1943 oldM <- liftIO $ readIORef $ _merge_accumRef m
2080 k <- getKey
1944 k <- getKey
@@ -2083,7 +1947,7 @@ mergeSubscriber subscribed m getKey = Subscriber
2083 liftIO $ writeIORef (_merge_accumRef m) $! newM
1947 liftIO $ writeIORef (_merge_accumRef m) $! newM
2084 when (DMap.null oldM) $ do -- Only schedule the firing once
1948 when (DMap.null oldM) $ do -- Only schedule the firing once
2085 height <- liftIO $ readIORef $ _merge_heightRef m
1949 height <- liftIO $ readIORef $ _merge_heightRef m
2086− checkCycle subscribed
1950+ -- checkCycle (_merge_sub m) height --TODO: assertions about height
2088 scheduleMergeSelf m height
1952 scheduleMergeSelf m height
2089 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1953 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
@@ -2095,11 +1959,11 @@ mergeSubscriber subscribed m getKey = Subscriber
2097--TODO: Be able to run as much of this as possible promptly
1961--TODO: Be able to run as much of this as possible promptly
2098−updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1962+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
2099−updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1963+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
2100 where updateMe = do
1964 where updateMe = do
2101 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1965 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
2102− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
1966+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
2103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1967 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
2104 return subscriptionsToKill
1968 return subscriptionsToKill
@@ -2112,28 +1976,14 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
2112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1976 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
2113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1977 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
2114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1978 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
2115− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2117− let subscribed = EventSubscribed
2118− { eventSubscribedHeightRef = heightRef
2119− , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2121− , eventSubscribedGetParents = do
2122− let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)
2123− fmap getParent' . DMap.toList <$> readIORef parentsRef
2124− , eventSubscribedHasOwnHeightRef = False
2125− , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2129− m = Merge
1979+ let m = Merge
2130 { _merge_parentsRef = parentsRef
1980 { _merge_parentsRef = parentsRef
2131 , _merge_heightBagRef = heightBagRef
1981 , _merge_heightBagRef = heightBagRef
2132 , _merge_heightRef = heightRef
1982 , _merge_heightRef = heightRef
2133 , _merge_sub = sub
1983 , _merge_sub = sub
2134 , _merge_accumRef = accumRef
1984 , _merge_accumRef = accumRef
2136− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
1986+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
2137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1987 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
2138 myHeight = if invalidHeight `elem` heights
1988 myHeight = if invalidHeight `elem` heights
2139 then invalidHeight
1989 then invalidHeight
@@ -2142,29 +1992,40 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
2142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1992 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
2143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1993 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
2144 else (Nothing, dm)
1994 else (Nothing, dm)
1995+ unless (DMap.null accum) $ do
2145− unless (DMap.null accum) $ scheduleMergeSelf m myHeight
1996+ scheduleMergeSelf m myHeight
2146 liftIO $ writeIORef accumRef $! accum
1997 liftIO $ writeIORef accumRef $! accum
2147 liftIO $ writeIORef heightRef $! myHeight
1998 liftIO $ writeIORef heightRef $! myHeight
2148 liftIO $ writeIORef heightBagRef $! myHeightBag
1999 liftIO $ writeIORef heightBagRef $! myHeightBag
2000+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2149 liftIO $ writeIORef parentsRef $! initialParentState
2001 liftIO $ writeIORef parentsRef $! initialParentState
2150 defer $ SomeMergeInit $ do
2002 defer $ SomeMergeInit $ do
2151− let changeSubscriber = Subscriber
2003+ let s = Subscriber
2152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2004 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2153− tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
2005+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
2154− defer $ updateMerge subscribed m updateFunc a
2006+ defer $ updateMerge m updateFunc a
2155 , subscriberInvalidateHeight = \_ -> return ()
2007 , subscriberInvalidateHeight = \_ -> return ()
2156 , subscriberRecalculateHeight = \_ -> return ()
2008 , subscriberRecalculateHeight = \_ -> return ()
2158− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2010+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2159− forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
2011+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
2160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2012 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2013 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2162 -- its subscription.
2014 -- its subscription.
2163− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2015+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2164 let unsubscribeAll = destroy =<< readIORef parentsRef
2016 let unsubscribeAll = destroy =<< readIORef parentsRef
2165−
2017+ getParent' = \(_ :=> v) -> _eventSubscription_subscribed (getParent v)
2018+ subscribed = EventSubscribed
2019+ { eventSubscribedHeightRef = heightRef
2020+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2022+ , eventSubscribedGetParents = fmap getParent' . DMap.toList <$> readIORef parentsRef
2023+ , eventSubscribedHasOwnHeightRef = False
2024+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2166 return (EventSubscription unsubscribeAll subscribed, occ)
2027 return (EventSubscription unsubscribeAll subscribed, occ)
2169mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2030mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2170mergeInt = cacheEvent . mergeIntCheap
2031mergeInt = cacheEvent . mergeIntCheap
@@ -2177,22 +2038,13 @@ mergeIntCheap d = Event $ \sub -> do
2177 heightRef <- liftIO $ newIORef zeroHeight
2038 heightRef <- liftIO $ newIORef zeroHeight
2178 heightBagRef <- liftIO $ newIORef heightBagEmpty
2039 heightBagRef <- liftIO $ newIORef heightBagEmpty
2179 parents <- liftIO $ FastMutableIntMap.newEmpty
2040 parents <- liftIO $ FastMutableIntMap.newEmpty
2180− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2181− let subscribed = EventSubscribed
2182− { eventSubscribedHeightRef = heightRef
2183− , eventSubscribedRetained = toAny (parents, changeSubdRef)
2185− , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2186− , eventSubscribedHasOwnHeightRef = False
2187− , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2190 let scheduleSelf = do
2041 let scheduleSelf = do
2191 height <- liftIO $ readIORef $ heightRef
2042 height <- liftIO $ readIORef $ heightRef
2192 scheduleMerge' height heightRef $ do
2043 scheduleMerge' height heightRef $ do
2193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2044 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2194 subscriberPropagate sub vals
2045 subscriberPropagate sub vals
2046+ invalidateMyHeight = do
2195− invalidateMyHeight = invalidateMergeHeight' heightRef sub
2047+ invalidateMergeHeight' heightRef sub
2196 recalculateMyHeight = do
2048 recalculateMyHeight = do
2197 currentHeight <- readIORef heightRef
2049 currentHeight <- readIORef heightRef
2198 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?
2050 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?
@@ -2202,14 +2054,14 @@ mergeIntCheap d = Event $ \sub -> do
2202 LT -> return ()
2054 LT -> return ()
2203 EQ -> do
2055 EQ -> do
2204 let height = succHeight $ heightBagMax heights
2056 let height = succHeight $ heightBagMax heights
2205− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2057+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2206 writeIORef heightRef $! height
2058 writeIORef heightRef $! height
2207 subscriberRecalculateHeight sub height
2059 subscriberRecalculateHeight sub height
2208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2060 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2209 mySubscriber k = Subscriber
2061 mySubscriber k = Subscriber
2210 { subscriberPropagate = \a -> do
2062 { subscriberPropagate = \a -> do
2211− checkCycle subscribed
2063+ -- liftIO (readIORef heightRef) >>= checkCycle
2213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2065 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2214 liftIO $ FastMutableIntMap.insert accum k a
2066 liftIO $ FastMutableIntMap.insert accum k a
2215 when wasEmpty scheduleSelf
2067 when wasEmpty scheduleSelf
@@ -2243,6 +2095,7 @@ mergeIntCheap d = Event $ \sub -> do
2243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2095 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2244 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2096 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2245 return Nothing
2097 return Nothing
2098+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2246 defer $ SomeMergeInit $ do
2099 defer $ SomeMergeInit $ do
2247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2100 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
@@ -2256,25 +2109,31 @@ mergeIntCheap d = Event $ \sub -> do
2256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2109 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2257 liftIO $ for_ oldParents $ \oldParent -> do
2110 liftIO $ for_ oldParents $ \oldParent -> do
2258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2111 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2260− print ("updateMe", oldParentHeight)
2261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2112 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2262 return $ IntMap.elems oldParents
2113 return $ IntMap.elems oldParents
2263− let changeSubscriber = Subscriber
2114+ let s = Subscriber
2264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2115 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2116 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2266 defer $ updateMe a
2117 defer $ updateMe a
2267 , subscriberInvalidateHeight = \_ -> return ()
2118 , subscriberInvalidateHeight = \_ -> return ()
2268 , subscriberRecalculateHeight = \_ -> return ()
2119 , subscriberRecalculateHeight = \_ -> return ()
2270− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2121+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2271 forM_ change $ \c -> defer $ updateMe c
2122 forM_ change $ \c -> defer $ updateMe c
2272 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2123 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2273 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2124 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2274 -- its subscription.
2125 -- its subscription.
2275− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2126+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2127 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2277−
2128+ subscribed = EventSubscribed
2129+ { eventSubscribedHeightRef = heightRef
2130+ , eventSubscribedRetained = toAny (parents, changeSubdRef)
2132+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2133+ , eventSubscribedHasOwnHeightRef = False
2134+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2279 return (EventSubscription unsubscribeAll subscribed, occ)
2138 return (EventSubscription unsubscribeAll subscribed, occ)
@@ -2385,7 +2244,7 @@ runFrame a = SpiderHost $ do
2385 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
2244 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
2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2246 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2247+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2389 EventRoot _ -> "EventRoot"
2248 EventRoot _ -> "EventRoot"
2390 EventNever -> "EventNever"
2249 EventNever -> "EventNever"
2391 _ -> "something else"
2250 _ -> "something else"
@@ -2400,7 +2259,7 @@ runFrame a = SpiderHost $ do
2400 myHeight <- readIORef $ switchSubscribedHeight subscribed
2259 myHeight <- readIORef $ switchSubscribedHeight subscribed
2401 when (parentHeight /= myHeight) $ do
2260 when (parentHeight /= myHeight) $ do
2402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2261 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2403− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2262+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2404 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
2263 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
2405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2264 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2406 unsubscribe subscription
2265 unsubscribe subscription
@@ -2441,7 +2300,7 @@ invalidateCoincidenceHeight subscribed = do
2441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2300 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2442 when (oldHeight /= invalidHeight) $ do
2301 when (oldHeight /= invalidHeight) $ do
2443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2302 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2444− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2303+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2305updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2447updateSwitchHeight new subscribed = do
2306updateSwitchHeight new subscribed = do
@@ -2449,7 +2308,7 @@ updateSwitchHeight new subscribed = do
2449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2308 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2309 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2451 writeIORef (switchSubscribedHeight subscribed) $! new
2310 writeIORef (switchSubscribedHeight subscribed) $! new
2452− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2311+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2313recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2455recalculateCoincidenceHeight subscribed = do
2314recalculateCoincidenceHeight subscribed = do
@@ -2458,7 +2317,7 @@ recalculateCoincidenceHeight subscribed = do
2458 height <- calculateCoincidenceHeight subscribed
2317 height <- calculateCoincidenceHeight subscribed
2459 when (height /= invalidHeight) $ do
2318 when (height /= invalidHeight) $ do
2460 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2319 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2461− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2320+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2322calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2323calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2520,8 +2379,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
2520 {-# INLINABLE headE #-}
2379 {-# INLINABLE headE #-}
2521 headE = R.slowHeadE
2380 headE = R.slowHeadE
2522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2381-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523− {-# INLINABLE now #-}
2524− now = nowSpiderEventM
2526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2383instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2527 {-# INLINABLE sample #-}
2384 {-# INLINABLE sample #-}
@@ -2543,9 +2400,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2543 {-# INLINABLE headE #-}
2400 {-# INLINABLE headE #-}
2544 headE = R.slowHeadE
2401 headE = R.slowHeadE
2545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2402-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546− {-# INLINABLE now #-}
2547− now = SpiderPushM nowSpiderEventM
2550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2404instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2551 {-# INLINE return #-}
2405 {-# INLINE return #-}
@@ -2554,10 +2408,8 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2408 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2555 {-# INLINE (>>) #-}
2409 {-# INLINE (>>) #-}
2556 (>>) = (*>)
2410 (>>) = (*>)
2557−#if !MIN_VERSION_base(4,13,0)
2558 {-# INLINE fail #-}
2411 {-# INLINE fail #-}
2559 fail _ = error "Dynamic does not support 'fail'"
2412 fail _ = error "Dynamic does not support 'fail'"
2562{-# INLINABLE newJoinDyn #-}
2414{-# INLINABLE newJoinDyn #-}
2563newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2415newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
@@ -2609,9 +2461,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2461 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2610 {-# INLINABLE headE #-}
2462 {-# INLINABLE headE #-}
2611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2463 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612− {-# INLINABLE now #-}
2613− now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2465instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2466 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2628,8 +2477,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2628 {-# INLINABLE headE #-}
2477 {-# INLINABLE headE #-}
2629 headE = R.slowHeadE
2478 headE = R.slowHeadE
2630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2479-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631− {-# INLINABLE now #-}
2632− now = SpiderHostFrame Reflex.Class.now
2634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2481instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2635 {-# INLINABLE sample #-}
2482 {-# INLINABLE sample #-}
@@ -2650,8 +2497,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
2650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2497 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2651 {-# INLINABLE headE #-}
2498 {-# INLINABLE headE #-}
2652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2499 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653− {-# INLINABLE now #-}
2654− now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
2656--------------------------------------------------------------------------------
2501--------------------------------------------------------------------------------
2657-- Deprecated items
2502-- Deprecated items
@@ -2775,7 +2620,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2620 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2776 {-# INLINABLE mergeG #-}
2621 {-# INLINABLE mergeG #-}
2778− :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2623+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2624 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2780 -> DMap k q
2625 -> DMap k q
2781 -> R.Event (SpiderTimeline x) (DMap k v)
2626 -> R.Event (SpiderTimeline x) (DMap k v)
@@ -2843,14 +2688,8 @@ instance Monad (SpiderHost x) where
2843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2688 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2844 {-# INLINABLE return #-}
2689 {-# INLINABLE return #-}
2845 return x = SpiderHost $ return x
2690 return x = SpiderHost $ return x
2846−#if !MIN_VERSION_base(4,13,0)
2847− {-# INLINABLE fail #-}
2848− fail = MonadFail.fail
2851−instance MonadFail (SpiderHost x) where
2852 {-# INLINABLE fail #-}
2691 {-# INLINABLE fail #-}
2853− fail s = SpiderHost $ MonadFail.fail s
2692+ fail s = SpiderHost $ fail s
2855-- | Run an action affecting the global Spider timeline; this will be guarded by
2694-- | Run an action affecting the global Spider timeline; this will be guarded by
2856-- a mutex for that timeline
2695-- a mutex for that timeline
@@ -2872,10 +2711,8 @@ instance Monad (SpiderHostFrame x) where
2872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2711 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2873 {-# INLINABLE return #-}
2712 {-# INLINABLE return #-}
2874 return x = SpiderHostFrame $ return x
2713 return x = SpiderHostFrame $ return x
2875−#if !MIN_VERSION_base(4,13,0)
2876 {-# INLINABLE fail #-}
2714 {-# INLINABLE fail #-}
2877 fail s = SpiderHostFrame $ fail s
2715 fail s = SpiderHostFrame $ fail s
2880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2717instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2881 notReadyUntil _ = pure ()
2718 notReadyUntil _ = pure ()
@@ -2920,11 +2757,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where
2920instance PrimMonad (SpiderHostFrame x) where
2757instance PrimMonad (SpiderHostFrame x) where
2921 type PrimState (SpiderHostFrame x) = PrimState IO
2758 type PrimState (SpiderHostFrame x) = PrimState IO
2922 primitive = SpiderHostFrame . EventM . primitive
2759 primitive = SpiderHostFrame . EventM . primitive
2924−instance NotReady (SpiderTimeline x) (SpiderHost x) where
2925− notReadyUntil _ = return ()
2926− notReady = return ()
2928−instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2929− notReadyUntil _ = return ()
2930− notReady = return ()