@@ -2,7 +2,6 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE ConstraintKinds #-}
44{-# LANGUAGE EmptyDataDecls #-}
5−{-# LANGUAGE ExistentialQuantification #-}
65{-# LANGUAGE FlexibleContexts #-}
76{-# LANGUAGE FlexibleInstances #-}
87{-# LANGUAGE FunctionalDependencies #-}
@@ -275,7 +274,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
275274eventNever :: Event x a
276275eventNever = Event $ \_ -> return (EventSubscription Nothing eventSubscribedNever, Nothing)
277276
278−eventMerge :: (GCompare k, a ~ DMap k Identity) => Merge x k -> Event x a
277+eventMerge :: GCompare k => Merge x k -> Event x (DMap k Identity)
279278eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m
280279
281280eventFan :: GCompare k => k a -> Fan x k -> Event x a
@@ -373,7 +372,7 @@ newSubscriberMergeChange :: GCompare k => MergeSubscribed x k -> IO (Subscriber
373372newSubscriberMergeChange subscribed = return $ Subscriber
374373 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
375374 tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
376− defer $ SomeMergeUpdate a subscribed
375+ defer $ SomeMergeUpdate (mkUpdateMerge a subscribed) (invalidateMergeHeight subscribed) (revalidateMergeHeight subscribed)
377376 , subscriberInvalidateHeight = \_ -> return ()
378377 , subscriberRecalculateHeight = \_ -> return ()
379378 }
@@ -932,9 +931,13 @@ data Root x (k :: * -> *)
932931
933932data SomeHoldInit x = forall p. R.Patch p => SomeHoldInit !(Hold x p)
934933
935−data SomeMergeUpdate x = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap k (Event x)) (MergeSubscribed x k)
934+data SomeMergeUpdate x = SomeMergeUpdate
935+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
936+ , _someMergeUpdate_invalidateHeight :: !(IO ())
937+ , _someMergeUpdate_recalculateHeight :: !(IO ())
938+ }
936939
937−data SomeMergeInit x = forall k. GCompare k => SomeMergeInit !(MergeSubscribed x k) !(Event x (R.PatchDMap k (Event x)))
940+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
938941
939942-- EventM can do everything BehaviorM can, plus create holds
940943newtype EventM x (a :: *) = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
@@ -1462,7 +1465,7 @@ getMergeSubscribed m sub = do
14621465 , mergeSubscribedNodeId = unsafeNodeId m
14631466#endif
14641467 }
1465− defer $ SomeMergeInit subscribed $ dynamicUpdated $ mergeParents m
1468+ defer $ SomeMergeInit $ mkInitMerge subscribed $ dynamicUpdated $ mergeParents m
14661469 liftIO $ writeIORef subscribedRef $! subscribed
14671470 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
14681471 liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
@@ -1673,19 +1676,40 @@ runHoldInits holdInitRef mergeInitRef = do
16731676 liftIO $ writeIORef holdInitRef []
16741677 liftIO $ writeIORef mergeInitRef []
16751678 mapM_ initHold holdInits
1676− mapM_ initMerge mergeInits
1679+ mapM_ unSomeMergeInit mergeInits
16771680 runHoldInits holdInitRef mergeInitRef
16781681
16791682initHold :: SomeHoldInit x -> EventM x ()
16801683initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
16811684
1682−initMerge :: SomeMergeInit x -> EventM x ()
1683−initMerge (SomeMergeInit subscribed changed) = do
1685+mkInitMerge :: GCompare k => MergeSubscribed x k -> Event x (R.PatchDMap k (Event x)) -> EventM x ()
1686+mkInitMerge subscribed changed = do
16841687 changeSub <- liftIO $ newSubscriberMergeChange subscribed
16851688 (EventSubscription _ changeSubd, change) <- subscribeAndRead changed changeSub
1686− forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1689+ forM_ change $ \c -> defer $ SomeMergeUpdate (mkUpdateMerge c subscribed) (invalidateMergeHeight subscribed) (revalidateMergeHeight subscribed)
16871690 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
16881691
1692+mkUpdateMerge :: forall k x. GCompare k => R.PatchDMap k (Event x) -> MergeSubscribed x k -> EventM x [EventSubscription x]
1693+mkUpdateMerge (R.PatchDMap p) m = do
1694+ oldParents <- liftIO $ readIORef $ mergeSubscribedParents m
1695+ let f (subscriptionsToKill, ps) (k :=> R.ComposeMaybe me) = do
1696+ (mOldSubd, newPs) <- case me of
1697+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1698+ Just e -> do
1699+ s <- liftIO $ newSubscriberMerge k m
1700+ subscription@(EventSubscription _ subd) <- subscribe e s
1701+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1702+ let newParent = MergeSubscribedParent subscription s
1703+ liftIO $ addMergeHeight newParentHeight m
1704+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1705+ forM_ mOldSubd $ \oldSubd -> do
1706+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1707+ liftIO $ removeMergeHeight oldHeight m
1708+ return (maybeToList (mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1709+ (subscriptionsToKill, newParents) <- foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1710+ liftIO $ writeIORef (mergeSubscribedParents m) $! newParents
1711+ return subscriptionsToKill
1712+
16891713-- | Run an event action outside of a frame
16901714runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
16911715runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
@@ -1720,28 +1744,8 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
17201744 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
17211745 mergeUpdates <- readIORef mergeUpdateRef
17221746 writeIORef mergeUpdateRef []
1723− let updateMerge :: SomeMergeUpdate x -> IO [EventSubscription x]
1724− updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap k (Event x)) m) = do
1725− oldParents <- readIORef $ mergeSubscribedParents m
1726− let f (subscriptionsToKill, ps) (k :=> R.ComposeMaybe me) = do
1727− (mOldSubd, newPs) <- case me of
1728− Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1729− Just e -> do
1730− s <- liftIO $ newSubscriberMerge k m
1731− subscription@(EventSubscription _ subd) <- subscribe e s
1732− newParentHeight <- liftIO $ getEventSubscribedHeight subd
1733− let newParent = MergeSubscribedParent subscription s
1734− liftIO $ addMergeHeight newParentHeight m
1735− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1736− forM_ mOldSubd $ \oldSubd -> do
1737− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1738− liftIO $ removeMergeHeight oldHeight m
1739− return (maybeToList (mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1740− (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1741− writeIORef (mergeSubscribedParents m) $! newParents
1742− return subscriptionsToKill
17431747 when debugPropagate $ putStrLn "Updating merges"
1744− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1748+ mergeSubscriptionsToKill <- flip runEventM env $ concat <$> mapM _someMergeUpdate_update mergeUpdates
17451749 when debugPropagate $ putStrLn "Updating merges done"
17461750 toReconnect <- readIORef toReconnectRef
17471751 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
@@ -1777,13 +1781,12 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
17771781 when (parentHeight /= myHeight) $ do
17781782 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
17791783 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1780− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> do
1781− invalidateMergeHeight m --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
1784+ 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
17821785 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
17831786 unsubscribe subscription
17841787 mapM_ invalidateCoincidenceHeight mcs
17851788 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1786− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1789+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
17871790 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
17881791 height <- calculateSwitchHeight subscribed
17891792 updateSwitchHeight height subscribed