@@ -64,7 +64,7 @@ import Data.Proxy
64import Data.These
64import Data.These
65import Data.Traversable
65import Data.Traversable
66import Data.Witherable (Filterable, mapMaybe)
66import Data.Witherable (Filterable, mapMaybe)
67−import GHC.Exts
67+import GHC.Exts hiding (toList)
68import GHC.IORef (IORef (..))
68import GHC.IORef (IORef (..))
69import GHC.Stack
69import GHC.Stack
70import Reflex.FastWeak
70import Reflex.FastWeak
@@ -86,8 +86,9 @@ import Data.Monoid (mempty)
86import Data.Tree (Forest, Tree (..), drawForest)
86import Data.Tree (Forest, Tree (..), drawForest)
89−import Data.FastWeakBag (FastWeakBag)
89+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
90import qualified Data.FastWeakBag as FastWeakBag
90import qualified Data.FastWeakBag as FastWeakBag
91import Data.Reflection
92import Data.Reflection
92import Data.Some (Some(Some))
93import Data.Some (Some(Some))
93import Data.Type.Coercion
94import Data.Type.Coercion
@@ -239,7 +240,7 @@ headE originalE = do
239 when (isJust occ) clearParent
240 when (isJust occ) clearParent
240 return $ Event $ \sub -> do
241 return $ Event $ \sub -> do
241 liftIO (readIORef parent) >>= \case
242 liftIO (readIORef parent) >>= \case
242− Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
243+ Nothing -> subscribeAndReadNever
243 Just e -> subscribeAndReadHead e sub
244 Just e -> subscribeAndReadHead e sub
245data CacheSubscribed x a
246data CacheSubscribed x a
@@ -293,25 +294,38 @@ cacheEvent e =
293 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
294 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
294 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
295 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
295 return subscribedTicket
296 return subscribedTicket
296− liftIO $ do
297+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
299+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
300+ -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
301+cacheSubscription sub mSubscribedRef subscribedTicket = do
297− subscribed <- getFastWeakTicketValue subscribedTicket
302+ subscribed <- getFastWeakTicketValue subscribedTicket
298− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
303+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
299− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
304+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
306+ let parentSub = _cacheSubscribed_parent subscribed
300− let es = EventSubscription
307+ es = EventSubscription
301− { _eventSubscription_unsubscribe = do
308+ { _eventSubscription_unsubscribe = do
302− FastWeakBag.remove ticket
309+ FastWeakBag.remove ticket
303− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
311+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
304− when isEmpty $ do
312+ when isEmpty $ do
305− writeIORef mSubscribedRef emptyFastWeak
313+ writeIORef mSubscribedRef emptyFastWeak
306− unsubscribe $ _cacheSubscribed_parent subscribed
314+ unsubscribe parentSub
307− touch ticket
315+ touch ticket
308− touch subscribedTicket
316+ touch subscribedTicket
309− , _eventSubscription_subscribed = EventSubscribed
317+ , _eventSubscription_subscribed = EventSubscribed
310− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
318+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub
311− , eventSubscribedRetained = toAny subscribedTicket
319+ , eventSubscribedRetained = toAny subscribedTicket
321+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
322+ , eventSubscribedHasOwnHeightRef = False
323+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
314− return (es, occ)
327+ return (es, occ)
316subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
330subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
317subscribe e s = fst <$> subscribeAndRead e s
331subscribe e s = fst <$> subscribeAndRead e s
@@ -326,8 +340,11 @@ wrap tag getSpecificSubscribed sub = do
326eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
340eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
327eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
341eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
343+subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
344+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
329eventNever :: Event x a
346eventNever :: Event x a
330−eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
347+eventNever = Event $ const subscribeAndReadNever
332eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
349eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
333eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
350eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
@@ -492,7 +509,7 @@ data EventSubscribed x = EventSubscribed
492 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
509 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
493 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
510 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
494#ifdef DEBUG_CYCLES
511#ifdef DEBUG_CYCLES
495− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
512+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
496 , eventSubscribedHasOwnHeightRef :: !Bool
513 , eventSubscribedHasOwnHeightRef :: !Bool
497 , eventSubscribedWhoCreated :: !(IO [String])
514 , eventSubscribedWhoCreated :: !(IO [String])
@@ -525,7 +542,7 @@ eventSubscribedFan !subscribed = EventSubscribed
525 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
542 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
526 , eventSubscribedRetained = toAny subscribed
543 , eventSubscribedRetained = toAny subscribed
527#ifdef DEBUG_CYCLES
544#ifdef DEBUG_CYCLES
528− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
545+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
529 , eventSubscribedHasOwnHeightRef = False
546 , eventSubscribedHasOwnHeightRef = False
530 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
547 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
@@ -538,7 +555,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
538#ifdef DEBUG_CYCLES
555#ifdef DEBUG_CYCLES
539 , eventSubscribedGetParents = do
556 , eventSubscribedGetParents = do
540 s <- readIORef $ switchSubscribedCurrentParent subscribed
557 s <- readIORef $ switchSubscribedCurrentParent subscribed
541− return [Some $ _eventSubscription_subscribed s]
558+ return [_eventSubscription_subscribed s]
542 , eventSubscribedHasOwnHeightRef = True
559 , eventSubscribedHasOwnHeightRef = True
543 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
560 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
@@ -551,8 +568,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
551#ifdef DEBUG_CYCLES
568#ifdef DEBUG_CYCLES
552 , eventSubscribedGetParents = do
569 , eventSubscribedGetParents = do
553 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
570 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
554− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
571+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
555− innerParents = maybeToList $ fmap Some innerSubscription
572+ innerParents = maybeToList $ innerSubscription
556 return $ outerParent : innerParents
573 return $ outerParent : innerParents
557 , eventSubscribedHasOwnHeightRef = True
574 , eventSubscribedHasOwnHeightRef = True
558 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
575 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -566,15 +583,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
566whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
583whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
567whoCreatedEventSubscribed = eventSubscribedWhoCreated
584whoCreatedEventSubscribed = eventSubscribedWhoCreated
569−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
586+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
570walkInvalidHeightParents s0 = do
587walkInvalidHeightParents s0 = do
571− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
588+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
572 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
589 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
573 when (h == invalidHeight) $ do
590 when (h == invalidHeight) $ do
574 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
591 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
575− modify (Some s :)
592+ modify (s :)
576 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
593 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
577− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
594+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
578 return subscribers
595 return subscribers
@@ -1510,16 +1527,16 @@ fanInt p = unsafePerformIO $ do
1510 { subscriberPropagate = \m -> do
1527 { subscriberPropagate = \m -> do
1511 liftIO $ writeIORef (_fanInt_occRef self) m
1528 liftIO $ writeIORef (_fanInt_occRef self) m
1512 scheduleIntClear $ _fanInt_occRef self
1529 scheduleIntClear $ _fanInt_occRef self
1513− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --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?
1514− FastWeakBag.traverse b $ \s -> do
1531+ FastWeakBag.traverse b $ \s ->
1515 subscriberPropagate s v
1532 subscriberPropagate s v
1516− , subscriberInvalidateHeight = \old -> do
1533+ , subscriberInvalidateHeight = \old ->
1517− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1534+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1518− FastWeakBag.traverse b $ \s -> do
1535+ FastWeakBag.traverse b $ \s ->
1519 subscriberInvalidateHeight s old
1536 subscriberInvalidateHeight s old
1520− , subscriberRecalculateHeight = \new -> do
1537+ , subscriberRecalculateHeight = \new ->
1521− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1538+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1522− FastWeakBag.traverse b $ \s -> do
1539+ FastWeakBag.traverse b $ \s ->
1523 subscriberRecalculateHeight s new
1540 subscriberRecalculateHeight s new
1525 liftIO $ do
1542 liftIO $ do
@@ -1533,10 +1550,25 @@ fanInt p = unsafePerformIO $ do
1533 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1550 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1534 return b
1551 return b
1535 Just b -> return b
1552 Just b -> return b
1536− t <- liftIO $ FastWeakBag.insert sub b
1553+ ticket <- liftIO $ FastWeakBag.insert sub b
1537 currentOcc <- readIORef (_fanInt_occRef self)
1554 currentOcc <- readIORef (_fanInt_occRef self)
1538− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1555+
1556+ subscribed <- fanIntSubscribed ticket self
1539− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1557+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1559+fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1560+fanIntSubscribed ticket self = do
1561+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1562+ return $ EventSubscribed
1563+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1564+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1566+ , eventSubscribedGetParents = return [subscribedParent]
1567+ , eventSubscribedHasOwnHeightRef = False
1568+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1541{-# INLINABLE getFanSubscribed #-}
1573{-# INLINABLE getFanSubscribed #-}
1542getFanSubscribed :: (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))
@@ -1734,7 +1766,7 @@ mergeCheap
1734 => (forall a. q a -> Event x (v a))
1766 => (forall a. q a -> Event x (v a))
1735 -> DynamicS x (PatchDMap k q)
1767 -> DynamicS x (PatchDMap k q)
1736 -> Event x (DMap k v)
1768 -> Event x (DMap k v)
1737−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1769+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy
1739 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1771 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1740 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1772 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
@@ -1749,7 +1781,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1749 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1781 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1750 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1782 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1751 forM_ mOldSubd $ \oldSubd -> do
1783 forM_ mOldSubd $ \oldSubd -> do
1784+ oldHeight <- liftIO $ getEventSubscribedHeight $
1752− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1785+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1753 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1787 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1754 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1788 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1755 foldM f ([], oldParents) $ DMap.toList p
1789 foldM f ([], oldParents) $ DMap.toList p
@@ -1774,7 +1808,7 @@ mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1774 => (forall a. q a -> Event x (v a))
1808 => (forall a. q a -> Event x (v a))
1775 -> DynamicS x (PatchDMapWithMove k q)
1809 -> DynamicS x (PatchDMapWithMove k q)
1776 -> Event x (DMap k v)
1810 -> Event x (DMap k v)
1777−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1811+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy
1779 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1813 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1780 updateMe subscriber heightBagRef oldParents p = do
1814 updateMe subscriber heightBagRef oldParents p = do
@@ -1793,13 +1827,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1793 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
1794 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1828 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1795 Nothing -> do
1829 Nothing -> do
1796− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1830+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1831+ _mergeSubscribedParentWithMove_subscription parent
1797 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1833 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1798 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1834 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1799 Just toKey -> do
1835 Just toKey -> do
1800 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1836 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1801 return Nothing
1837 return Nothing
1838+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1802− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1839+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1803 return (toDelete, applyAlways p' oldParents)
1841 return (toDelete, applyAlways p' oldParents)
1804 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1842 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1805 getInitialSubscribers initialParents subscriber = do
1843 getInitialSubscribers initialParents subscriber = do
@@ -1824,6 +1862,8 @@ type MergeUpdateFunc k v x p s
1825 -> EventM x ([EventSubscription x], DMap k s)
1863 -> EventM x ([EventSubscription x], DMap k s)
1865+type MergeGetSubscription x s = forall a. s a -> EventSubscription x
1827type MergeInitFunc k v q x s
1867type MergeInitFunc k v q x s
1828 = DMap k q
1868 = DMap k q
1829 -> (forall a. EventM x (k a) -> Subscriber x (v a))
1869 -> (forall a. EventM x (k a) -> Subscriber x (v a))
@@ -1847,14 +1887,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su
1847invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1887invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1848invalidateMergeHeight' heightRef sub = do
1888invalidateMergeHeight' heightRef sub = do
1849 oldHeight <- readIORef heightRef
1889 oldHeight <- readIORef heightRef
1850− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1890+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1891+ when (oldHeight /= invalidHeight) $ do
1851 writeIORef heightRef $! invalidHeight
1892 writeIORef heightRef $! invalidHeight
1852 subscriberInvalidateHeight sub oldHeight
1893 subscriberInvalidateHeight sub oldHeight
1854revalidateMergeHeight :: Merge x k v s -> IO ()
1895revalidateMergeHeight :: Merge x k v s -> IO ()
1855revalidateMergeHeight m = do
1896revalidateMergeHeight m = do
1856 currentHeight <- readIORef $ _merge_heightRef m
1897 currentHeight <- readIORef $ _merge_heightRef m
1857− when (currentHeight == invalidHeight) $ do -- 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
1900+ when (currentHeight == invalidHeight) $ do
1858 heights <- readIORef $ _merge_heightBagRef m
1901 heights <- readIORef $ _merge_heightBagRef m
1859 parents <- readIORef $ _merge_parentsRef m
1902 parents <- readIORef $ _merge_parentsRef m
1860 -- 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
@@ -1870,22 +1913,25 @@ revalidateMergeHeight m = do
1870scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1913scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1871scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1914scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1872 vals <- liftIO $ readIORef $ _merge_accumRef m
1915 vals <- liftIO $ readIORef $ _merge_accumRef m
1873− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1916+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
1917+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1918+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
1874 --TODO: Assert that m is not empty
1919 --TODO: Assert that m is not empty
1875 subscriberPropagate (_merge_sub m) vals
1920 subscriberPropagate (_merge_sub m) vals
1877−checkCycle :: HasSpiderTimeline x => Height -> EventM x ()
1922+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> Height -> EventM x ()
1878−checkCycle height = do
1923+checkCycle subscribed height = do
1879 currentHeight <- getCurrentHeight
1924 currentHeight <- getCurrentHeight
1880 when (height <= currentHeight) $ if height /= invalidHeight
1925 when (height <= currentHeight) $ if height /= invalidHeight
1882 myStack <- liftIO $ whoCreatedIORef undefined --TODO
1927 myStack <- liftIO $ whoCreatedIORef undefined --TODO
1883 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)
1884− else liftIO $ do
1929+ else liftIO $
1885#ifdef DEBUG_CYCLES
1930#ifdef DEBUG_CYCLES
1886− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1932+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
1887− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1933+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
1888− throwIO (EventLoopException stacks)
1934+ throwIO (EventLoopException (listsToForest stacks))
1890 throwIO EventLoopException
1936 throwIO EventLoopException
@@ -1896,12 +1942,12 @@ mergeSubscriber m getKey = Subscriber
1896 { subscriberPropagate = \a -> do
1942 { subscriberPropagate = \a -> do
1897 oldM <- liftIO $ readIORef $ _merge_accumRef m
1943 oldM <- liftIO $ readIORef $ _merge_accumRef m
1898 k <- getKey
1944 k <- getKey
1899− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1945+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
1900 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1946 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1901 liftIO $ writeIORef (_merge_accumRef m) $! newM
1947 liftIO $ writeIORef (_merge_accumRef m) $! newM
1902 when (DMap.null oldM) $ do -- Only schedule the firing once
1948 when (DMap.null oldM) $ do -- Only schedule the firing once
1903 height <- liftIO $ readIORef $ _merge_heightRef m
1949 height <- liftIO $ readIORef $ _merge_heightRef m
1904− checkCycle height --TODO: assertions about height
1950+ -- checkCycle (_merge_sub m) height --TODO: assertions about height
1906 scheduleMergeSelf m height
1952 scheduleMergeSelf m height
1907 , 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
@@ -1923,8 +1969,8 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1924{-# INLINE mergeGCheap' #-}
1970{-# INLINE mergeGCheap' #-}
1925mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1971mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1926− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1972+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1927−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1973+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1928 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1974 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1929 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1975 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1930 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1976 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1968,9 +2014,18 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1968 -- its subscription.
2014 -- its subscription.
1969 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2015 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1970 let unsubscribeAll = destroy =<< readIORef parentsRef
2016 let unsubscribeAll = destroy =<< readIORef parentsRef
2017+ getParent' = \(_ :=> v) -> _eventSubscription_subscribed (getParent v)
2018+ subscribed = EventSubscribed
2019+ { eventSubscribedHeightRef = heightRef
1971− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
2020+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
1972− , occ
2021+#ifdef DEBUG_CYCLES
1973− )
2022+ , eventSubscribedGetParents = fmap getParent' . DMap.toList <$> readIORef parentsRef
2023+ , eventSubscribedHasOwnHeightRef = False
2024+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2027+ return (EventSubscription unsubscribeAll subscribed, occ)
1975mergeInt :: 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)
1976mergeInt = cacheEvent . mergeIntCheap
2031mergeInt = cacheEvent . mergeIntCheap
@@ -2005,7 +2060,7 @@ mergeIntCheap d = Event $ \sub -> do
2005 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"
2006 mySubscriber k = Subscriber
2061 mySubscriber k = Subscriber
2007 { subscriberPropagate = \a -> do
2062 { subscriberPropagate = \a -> do
2008− liftIO (readIORef heightRef) >>= checkCycle
2063+ -- liftIO (readIORef heightRef) >>= checkCycle
2010 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2065 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2011 liftIO $ FastMutableIntMap.insert accum k a
2066 liftIO $ FastMutableIntMap.insert accum k a
@@ -2070,9 +2125,17 @@ mergeIntCheap d = Event $ \sub -> do
2070 -- its subscription.
2125 -- its subscription.
2071 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2126 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2072 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2127 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
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
2073− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2138+ return (EventSubscription unsubscribeAll subscribed, occ)
2077newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2140newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2078newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2141newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }