@@ -47,6 +47,8 @@ import qualified Data.Dependent.Map as DMap
47import Data.Foldable hiding (concat, elem, sequence_)
47import Data.Foldable hiding (concat, elem, sequence_)
48import Data.Function
48import Data.Function
49import Data.Functor.Compose
49import Data.Functor.Compose
50+import Data.Functor.Constant
51+import Data.Functor.Product
50import Data.GADT.Compare
52import Data.GADT.Compare
51import Data.IntMap.Strict (IntMap)
53import Data.IntMap.Strict (IntMap)
52import qualified Data.IntMap.Strict as IntMap
54import qualified Data.IntMap.Strict as IntMap
@@ -330,14 +332,11 @@ newSubscriberFan subscribed = return $ Subscriber
330 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
332 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
331 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
333 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
332 tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
334 tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
333− --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
335+ let f _ (Pair (Identity v) subsubs) = do
334− forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
336+ propagate v $ _fanSubscribedChildren_list subsubs
335− Nothing -> do
337+ return $ Constant ()
336− tracePropagate "No subscriber for key"
338+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
339− propagate v $ _fanSubscribedChildren_list subsubs
340− return ()
339+ return ()
341 , subscriberInvalidateHeight = \old -> do
340 , subscriberInvalidateHeight = \old -> do
342 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
341 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
343 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
342 subscribers <- readIORef $ fanSubscribedSubscribers subscribed