@@ -183,7 +183,186 @@ unsafeNodeId a = unsafePerformIO $ do
183 newNodeId
183 newNodeId
186+--------------------------------------------------------------------------------
188+--------------------------------------------------------------------------------
191+ = forall k. GCompare k => EventRoot !(k a) !(Root k)
193+ | forall b. EventPush !(Push b a)
194+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
195+ | forall k. GCompare k => EventFan !(k a) !(Fan k)
196+ | EventSwitch !(Switch a)
197+ | EventCoincidence !(Coincidence a)
198+ | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
199+ | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
200+ | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
201+ | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
203+{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
204+subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
205+subscribe e sub = case e of
206+ EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
207+ EventNever -> return $ EventSubscription Nothing EventSubscribedNever
208+ EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
209+ EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
210+ EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
211+ EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
212+ EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
213+ EventHold h -> subscribeHoldEvent h sub
214+ EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
215+ EventHoldIdentity h -> subscribeHoldEvent h sub
216+ EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
218+ wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
219+ wrap tag getSpecificSubscribed = do
220+ (sln, subd) <- getSpecificSubscribed sub
221+ return $ EventSubscription (Just sln) $ tag subd
223+{-# INLINE subscribeCoincidenceInner #-}
224+subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
225+subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
226+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
227+ subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
228+ innerOcc <- liftIO $ readEventSubscribed innerSubd
229+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
230+ let height = max innerHeight outerHeight
231+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
232+ return (innerOcc, height, innerSubd)
234+--------------------------------------------------------------------------------
236+--------------------------------------------------------------------------------
238+data EventSubscribed a
239+ = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
240+ | EventSubscribedNever
241+ | forall b. EventSubscribedPush !(PushSubscribed b a)
242+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
243+ | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
244+ | EventSubscribedSwitch !(SwitchSubscribed a)
245+ | EventSubscribedCoincidence !(CoincidenceSubscribed a)
247+readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
248+readEventSubscribed = \case
249+ EventSubscribedRoot rs -> readRootSubscribed rs
250+ EventSubscribedNever -> return Nothing
251+ EventSubscribedPush ps -> readPushSubscribed ps
252+ EventSubscribedMerge ms -> readMergeSubscribed ms
253+ EventSubscribedFan k fs -> readFanSubscribed k fs
254+ EventSubscribedSwitch ss -> readSwitchSubscribed ss
255+ EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
257+{-# INLINE subscribeEventSubscribed #-}
258+subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
259+subscribeEventSubscribed es sub = case es of
260+ EventSubscribedRoot r -> do
261+ traceSubscribe $ "subscribeEventSubscribed Root"
262+ Just <$> subscribeRootSubscribed r sub
263+ EventSubscribedNever -> do
264+ traceSubscribe $ "subscribeEventSubscribed Never"
266+ EventSubscribedPush subscribed -> do
267+ traceSubscribe $ "subscribeEventSubscribed Push"
268+ Just <$> subscribePushSubscribed subscribed sub
269+ EventSubscribedFan k subscribed -> do
270+ traceSubscribe $ "subscribeEventSubscribed Fan"
271+ Just <$> subscribeFanSubscribed k subscribed sub
272+ EventSubscribedMerge subscribed -> do
273+ traceSubscribe $ "subscribeEventSubscribed Merge"
274+ Just <$> subscribeMergeSubscribed subscribed sub
275+ EventSubscribedSwitch subscribed -> do
276+ traceSubscribe $ "subscribeEventSubscribed Switch"
277+ Just <$> subscribeSwitchSubscribed subscribed sub
278+ EventSubscribedCoincidence subscribed -> do
279+ traceSubscribe $ "subscribeEventSubscribed Coincidence"
280+ Just <$> subscribeCoincidenceSubscribed subscribed sub
282+{-# INLINE eventSubscribedGetParents #-}
283+eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
284+eventSubscribedGetParents = \case
285+ EventSubscribedRoot _ -> return []
286+ EventSubscribedNever -> return []
287+ EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
288+ EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
289+ EventSubscribedMerge subscribed -> do
290+ ps <- readIORef $ mergeSubscribedParents subscribed
291+ return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
292+ EventSubscribedSwitch subscribed -> do
293+ s <- readIORef $ switchSubscribedCurrentParent subscribed
294+ return [Some.This $ _eventSubscription_subscribed s]
295+ EventSubscribedCoincidence subscribed -> do
296+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
297+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
298+ innerParents = maybeToList $ fmap Some.This innerSubscription
299+ return $ outerParent : innerParents
301+getEventSubscribedHeight :: EventSubscribed a -> IO Height
302+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
304+{-# INLINE eventSubscribedHeightRef #-}
305+eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
306+eventSubscribedHeightRef = \case
307+ EventSubscribedRoot _ -> zeroRef
308+ EventSubscribedNever -> zeroRef
309+ EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
310+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
311+ EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
312+ EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
313+ EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
315+whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
316+whoCreatedEventSubscribed = \case
317+ EventSubscribedRoot _ -> return ["root"]
318+ EventSubscribedNever -> return ["never"]
319+ EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
320+ EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
321+ EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
322+ EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
323+ EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
325+{-# INLINE eventSubscribedHasOwnHeightRef #-}
326+eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
327+eventSubscribedHasOwnHeightRef = \case
328+ EventSubscribedRoot _ -> False
329+ EventSubscribedNever -> False
330+ EventSubscribedPush _ -> False
331+ EventSubscribedFan _ _ -> False
332+ EventSubscribedMerge _ -> True
333+ EventSubscribedSwitch _ -> True
334+ EventSubscribedCoincidence _ -> True
336+walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
337+walkInvalidHeightParents s0 = do
338+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
339+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
340+ when (h == invalidHeight) $ do
341+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
342+ modify (Some.This s :)
343+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
344+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
347+--------------------------------------------------------------------------------
349+--------------------------------------------------------------------------------
351+data EventSubscription a = EventSubscription
352+ { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
353+ , _eventSubscription_subscribed :: !(EventSubscribed a)
356+unsubscribe :: EventSubscription a -> IO ()
357+unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
359+--------------------------------------------------------------------------------
361+--------------------------------------------------------------------------------
186−--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
363+--TODO: Figure out why certain things are not 'representational', then make them
364+--representational so we can use coerce
187--type role Hold representational
366--type role Hold representational
188data Hold p a
367data Hold p a
189 = Hold { holdValue :: !(IORef a)
368 = Hold { holdValue :: !(IORef a)
@@ -579,36 +758,6 @@ data Subscriber a
579 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
758 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
580 | SubscriberHandle
759 | SubscriberHandle
583− = forall k. GCompare k => EventRoot !(k a) !(Root k)
585− | forall b. EventPush !(Push b a)
586− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
587− | forall k. GCompare k => EventFan !(k a) !(Fan k)
588− | EventSwitch !(Switch a)
589− | EventCoincidence !(Coincidence a)
590− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
591− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
592− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
593− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
595−data EventSubscription a = EventSubscription
596− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
597− , _eventSubscription_subscribed :: !(EventSubscribed a)
600−data EventSubscribed a
601− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
602− | EventSubscribedNever
603− | forall b. EventSubscribedPush !(PushSubscribed b a)
604− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
605− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
606− | EventSubscribedSwitch !(SwitchSubscribed a)
607− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
609−unsubscribe :: EventSubscription a -> IO ()
610−unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
612-- These function are constructor functions that are marked NOINLINE so they are
761-- These function are constructor functions that are marked NOINLINE so they are
613-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
762-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
614-- so any weak references that are attached to the constructors will have their
763-- so any weak references that are attached to the constructors will have their
@@ -924,27 +1073,6 @@ traceMWhen b getMessage = when b $ do
924whoCreatedIORef :: IORef a -> IO [String]
1073whoCreatedIORef :: IORef a -> IO [String]
925whoCreatedIORef (IORef a) = whoCreated $! a
1074whoCreatedIORef (IORef a) = whoCreated $! a
927−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
928−whoCreatedEventSubscribed = \case
929− EventSubscribedRoot _ -> return ["root"]
930− EventSubscribedNever -> return ["never"]
931− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
932− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
933− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
934− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
935− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
937−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
938−walkInvalidHeightParents s0 = do
939− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
940− h <- liftIO $ readIORef $ eventSubscribedHeightRef s
941− when (h == invalidHeight) $ do
942− when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
943− modify (Some.This s :)
944− mapM_ loop =<< liftIO (eventSubscribedGetParents s)
945− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
948groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1076groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
949groupByHead = \case
1077groupByHead = \case
950 [] -> []
1078 [] -> []
@@ -1059,17 +1187,6 @@ propagateSubscriberHold h a = do
1060data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1188data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1062−{-# INLINE subscribeCoincidenceInner #-}
1063−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
1064−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
1065− subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1066− subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
1067− innerOcc <- liftIO $ readEventSubscribed innerSubd
1068− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
1069− let height = max innerHeight outerHeight
1070− defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
1071− return (innerOcc, height, innerSubd)
1073{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1190{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1074{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1191{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1075readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1192readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
@@ -1153,16 +1270,6 @@ getDynHold d = do
1153 liftIO $ writeIORef (unDyn d) $ Right h
1270 liftIO $ writeIORef (unDyn d) $ Right h
1154 return h
1271 return h
1156−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1157−readEventSubscribed = \case
1158− EventSubscribedRoot rs -> readRootSubscribed rs
1159− EventSubscribedNever -> return Nothing
1160− EventSubscribedPush ps -> readPushSubscribed ps
1161− EventSubscribedMerge ms -> readMergeSubscribed ms
1162− EventSubscribedFan k fs -> readFanSubscribed k fs
1163− EventSubscribedSwitch ss -> readSwitchSubscribed ss
1164− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1166readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1273readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1167readRootSubscribed = rootSubscribedOccurrence
1274readRootSubscribed = rootSubscribedOccurrence
@@ -1201,26 +1308,6 @@ readCoincidenceSubscribed subscribed = do
1201zeroRef :: IORef Height
1308zeroRef :: IORef Height
1202zeroRef = unsafePerformIO $ newIORef zeroHeight
1309zeroRef = unsafePerformIO $ newIORef zeroHeight
1204−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1205−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1206−subscribe e sub = case e of
1207− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1208− EventNever -> return $ EventSubscription Nothing EventSubscribedNever
1209− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
1210− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
1211− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
1212− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
1213− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
1214− EventHold h -> subscribeHoldEvent h sub
1215− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1216− EventHoldIdentity h -> subscribeHoldEvent h sub
1217− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1219− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1220− wrap tag getSpecificSubscribed = do
1221− (sln, subd) <- getSpecificSubscribed sub
1222− return $ EventSubscription (Just sln) $ tag subd
1224{-# INLINE subscribeHoldEvent #-}
1311{-# INLINE subscribeHoldEvent #-}
1225subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1312subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1226subscribeHoldEvent h sub = do
1313subscribeHoldEvent h sub = do
@@ -1232,71 +1319,6 @@ subscribeHoldEvent h sub = do
1232debugSubscribe :: Bool
1319debugSubscribe :: Bool
1233debugSubscribe = False
1320debugSubscribe = False
1235−{-# INLINE subscribeEventSubscribed #-}
1236−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
1237−subscribeEventSubscribed es sub = case es of
1238− EventSubscribedRoot r -> do
1239− traceSubscribe $ "subscribeEventSubscribed Root"
1240− Just <$> subscribeRootSubscribed r sub
1241− EventSubscribedNever -> do
1242− traceSubscribe $ "subscribeEventSubscribed Never"
1244− EventSubscribedPush subscribed -> do
1245− traceSubscribe $ "subscribeEventSubscribed Push"
1246− Just <$> subscribePushSubscribed subscribed sub
1247− EventSubscribedFan k subscribed -> do
1248− traceSubscribe $ "subscribeEventSubscribed Fan"
1249− Just <$> subscribeFanSubscribed k subscribed sub
1250− EventSubscribedMerge subscribed -> do
1251− traceSubscribe $ "subscribeEventSubscribed Merge"
1252− Just <$> subscribeMergeSubscribed subscribed sub
1253− EventSubscribedSwitch subscribed -> do
1254− traceSubscribe $ "subscribeEventSubscribed Switch"
1255− Just <$> subscribeSwitchSubscribed subscribed sub
1256− EventSubscribedCoincidence subscribed -> do
1257− traceSubscribe $ "subscribeEventSubscribed Coincidence"
1258− Just <$> subscribeCoincidenceSubscribed subscribed sub
1260−{-# INLINE eventSubscribedHeightRef #-}
1261−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
1262−eventSubscribedHeightRef = \case
1263− EventSubscribedRoot _ -> zeroRef
1264− EventSubscribedNever -> zeroRef
1265− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1266− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
1267− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
1268− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
1269− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
1271−{-# INLINE eventSubscribedHasOwnHeightRef #-}
1272−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1273−eventSubscribedHasOwnHeightRef = \case
1274− EventSubscribedRoot _ -> False
1275− EventSubscribedNever -> False
1276− EventSubscribedPush _ -> False
1277− EventSubscribedFan _ _ -> False
1278− EventSubscribedMerge _ -> True
1279− EventSubscribedSwitch _ -> True
1280− EventSubscribedCoincidence _ -> True
1282−{-# INLINE eventSubscribedGetParents #-}
1283−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1284−eventSubscribedGetParents = \case
1285− EventSubscribedRoot _ -> return []
1286− EventSubscribedNever -> return []
1287− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
1288− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
1289− EventSubscribedMerge subscribed -> do
1290− ps <- readIORef $ mergeSubscribedParents subscribed
1291− return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
1292− EventSubscribedSwitch subscribed -> do
1293− s <- readIORef $ switchSubscribedCurrentParent subscribed
1294− return [Some.This $ _eventSubscription_subscribed s]
1295− EventSubscribedCoincidence subscribed -> do
1296− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1297− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1298− innerParents = maybeToList $ fmap Some.This innerSubscription
1299− return $ outerParent : innerParents
1301type CanSubscribe x m =
1323type CanSubscribe x m =
1302 ( HasSpiderEnv x m
1324 ( HasSpiderEnv x m
@@ -1406,12 +1428,12 @@ getMergeSubscribed m sub = do
1406 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1428 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1407 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1429 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1408 initialParents <- readBehaviorUntracked $ current $ mergeParents m
1430 initialParents <- readBehaviorUntracked $ current $ mergeParents m
1409− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1431+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> do
1410− s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1432+ s <- {-# SCC "getMergeSubscribed.a.1" #-} liftIO $ newSubscriberMerge k subscribedUnsafe
1411− subscription@(EventSubscription _ parentSubd) <- subscribe e s
1433+ subscription@(EventSubscription _ parentSubd) <- {-# SCC "getMergeSubscribed.a.2" #-} subscribe e s
1412− parentOcc <- liftIO $ readEventSubscribed parentSubd
1434+ parentOcc <- {-# SCC "getMergeSubscribed.a.3" #-} liftIO $ readEventSubscribed parentSubd
1413− height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1435+ height <- {-# SCC "getMergeSubscribed.a.4" #-} liftIO $ getEventSubscribedHeight parentSubd
1414− return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)
1436+ {-# SCC "getMergeSubscribed.a.5" #-} return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)
1415 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1437 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1416 heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1438 heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1417 myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1439 myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
@@ -1542,7 +1564,7 @@ getSwitchSubscribed s sub = do
1542 parentOcc <- liftIO $ readEventSubscribed subd
1564 parentOcc <- liftIO $ readEventSubscribed subd
1543 occRef <- liftIO $ newIORef parentOcc
1565 occRef <- liftIO $ newIORef parentOcc
1544 when (isJust parentOcc) $ scheduleClear occRef
1566 when (isJust parentOcc) $ scheduleClear occRef
1545− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
1567+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1546 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1568 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1547 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1569 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1548 let !subscribed = SwitchSubscribed
1570 let !subscribed = SwitchSubscribed
@@ -1589,7 +1611,7 @@ getCoincidenceSubscribed c sub = do
1589 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1611 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1590 outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
1612 outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
1591 outerOcc <- liftIO $ readEventSubscribed outerSubd
1613 outerOcc <- liftIO $ readEventSubscribed outerSubd
1592− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1614+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1593 (occ, height, mInnerSubd) <- case outerOcc of
1615 (occ, height, mInnerSubd) <- case outerOcc of
1594 Nothing -> return (Nothing, outerHeight, Nothing)
1616 Nothing -> return (Nothing, outerHeight, Nothing)
1595 Just o -> do
1617 Just o -> do
@@ -1716,7 +1738,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1716 liftIO $ addMergeHeight newParentHeight m
1738 liftIO $ addMergeHeight newParentHeight m
1717 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1739 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1718 forM_ mOldSubd $ \oldSubd -> do
1740 forM_ mOldSubd $ \oldSubd -> do
1719− oldHeight <- liftIO $ readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1741+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1720 liftIO $ removeMergeHeight oldHeight m
1742 liftIO $ removeMergeHeight oldHeight m
1721 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1743 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1722 (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
1744 (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
@@ -1754,7 +1776,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1754 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1776 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1755 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1777 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1756 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1778 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1757− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1779+ parentHeight <- getEventSubscribedHeight subd'
1758 myHeight <- readIORef $ switchSubscribedHeight subscribed
1780 myHeight <- readIORef $ switchSubscribedHeight subscribed
1759 when (parentHeight /= myHeight) $ do
1781 when (parentHeight /= myHeight) $ do
1760 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1782 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
@@ -1924,16 +1946,13 @@ recalculateCoincidenceHeight subscribed = do
1924 writeIORef (coincidenceSubscribedHeight subscribed) $! height
1946 writeIORef (coincidenceSubscribedHeight subscribed) $! height
1925 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1947 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1927−getEventSubscribedHeight :: EventSubscribed a -> IO Height
1928−getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
1930calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1949calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1931−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1950+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1933calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1952calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1934calculateCoincidenceHeight subscribed = do
1953calculateCoincidenceHeight subscribed = do
1935− outerHeight <- readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1954+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1936− innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1955+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1937 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1956 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1939data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1958data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)