@@ -2,7 +2,6 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE EmptyDataDecls #-}
5−{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE FunctionalDependencies #-}
@@ -275,7 +274,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
275eventNever :: Event x a
274eventNever :: Event x a
276eventNever = Event $ \_ -> return (EventSubscription Nothing eventSubscribedNever, Nothing)
275eventNever = Event $ \_ -> return (EventSubscription Nothing eventSubscribedNever, Nothing)
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)
279eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m
278eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m
281eventFan :: GCompare k => k a -> Fan x k -> Event x a
280eventFan :: GCompare k => k a -> Fan x k -> Event x a
@@ -373,7 +372,7 @@ newSubscriberMergeChange :: GCompare k => MergeSubscribed x k -> IO (Subscriber
373newSubscriberMergeChange subscribed = return $ Subscriber
372newSubscriberMergeChange subscribed = return $ Subscriber
374 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
373 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
375 tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
374 tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
376− defer $ SomeMergeUpdate a subscribed
375+ defer $ SomeMergeUpdate (mkUpdateMerge a subscribed) (invalidateMergeHeight subscribed) (revalidateMergeHeight subscribed)
377 , subscriberInvalidateHeight = \_ -> return ()
376 , subscriberInvalidateHeight = \_ -> return ()
378 , subscriberRecalculateHeight = \_ -> return ()
377 , subscriberRecalculateHeight = \_ -> return ()
@@ -932,9 +931,13 @@ data Root x (k :: * -> *)
933data SomeHoldInit x = forall p. R.Patch p => SomeHoldInit !(Hold x p)
932data SomeHoldInit x = forall p. R.Patch p => SomeHoldInit !(Hold x p)
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 ())
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 () }
939-- EventM can do everything BehaviorM can, plus create holds
942-- EventM can do everything BehaviorM can, plus create holds
940newtype 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
943newtype 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
1462 , mergeSubscribedNodeId = unsafeNodeId m
1465 , mergeSubscribedNodeId = unsafeNodeId m
1465− defer $ SomeMergeInit subscribed $ dynamicUpdated $ mergeParents m
1468+ defer $ SomeMergeInit $ mkInitMerge subscribed $ dynamicUpdated $ mergeParents m
1466 liftIO $ writeIORef subscribedRef $! subscribed
1469 liftIO $ writeIORef subscribedRef $! subscribed
1467 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1470 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1468 liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
1471 liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
@@ -1673,19 +1676,40 @@ runHoldInits holdInitRef mergeInitRef = do
1673 liftIO $ writeIORef holdInitRef []
1676 liftIO $ writeIORef holdInitRef []
1674 liftIO $ writeIORef mergeInitRef []
1677 liftIO $ writeIORef mergeInitRef []
1675 mapM_ initHold holdInits
1678 mapM_ initHold holdInits
1676− mapM_ initMerge mergeInits
1679+ mapM_ unSomeMergeInit mergeInits
1677 runHoldInits holdInitRef mergeInitRef
1680 runHoldInits holdInitRef mergeInitRef
1679initHold :: SomeHoldInit x -> EventM x ()
1682initHold :: SomeHoldInit x -> EventM x ()
1680initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1683initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1682−initMerge :: SomeMergeInit x -> EventM x ()
1685+mkInitMerge :: GCompare k => MergeSubscribed x k -> Event x (R.PatchDMap k (Event x)) -> EventM x ()
1683−initMerge (SomeMergeInit subscribed changed) = do
1686+mkInitMerge subscribed changed = do
1684 changeSub <- liftIO $ newSubscriberMergeChange subscribed
1687 changeSub <- liftIO $ newSubscriberMergeChange subscribed
1685 (EventSubscription _ changeSubd, change) <- subscribeAndRead changed changeSub
1688 (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)
1687 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
1690 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
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
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
1689-- | Run an event action outside of a frame
1713-- | Run an event action outside of a frame
1690runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1714runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1691runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1715runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
@@ -1720,28 +1744,8 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1720 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1744 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1721 mergeUpdates <- readIORef mergeUpdateRef
1745 mergeUpdates <- readIORef mergeUpdateRef
1722 writeIORef mergeUpdateRef []
1746 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
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
1743 when debugPropagate $ putStrLn "Updating merges"
1747 when debugPropagate $ putStrLn "Updating merges"
1744− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1748+ mergeSubscriptionsToKill <- flip runEventM env $ concat <$> mapM _someMergeUpdate_update mergeUpdates
1745 when debugPropagate $ putStrLn "Updating merges done"
1749 when debugPropagate $ putStrLn "Updating merges done"
1746 toReconnect <- readIORef toReconnectRef
1750 toReconnect <- readIORef toReconnectRef
1747 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1751 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
@@ -1777,13 +1781,12 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1777 when (parentHeight /= myHeight) $ do
1781 when (parentHeight /= myHeight) $ do
1778 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1782 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1779 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1783 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
1782 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1785 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1783 unsubscribe subscription
1786 unsubscribe subscription
1784 mapM_ invalidateCoincidenceHeight mcs
1787 mapM_ invalidateCoincidenceHeight mcs
1785 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1788 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1786− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1789+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
1787 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1790 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1788 height <- calculateSwitchHeight subscribed
1791 height <- calculateSwitchHeight subscribed
1789 updateSwitchHeight height subscribed
1792 updateSwitchHeight height subscribed