24330d8 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Reorganize the event reading stuff

24330d8Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+82−50

compare with develop

unifiedsplit

@@ -39,7 +39,6 @@ import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)

39import Control.Monad.Primitive

40import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)

41import Control.Monad.Ref

42−import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

43import Data.Align

42import Data.Align

44import Data.Coerce

43import Data.Coerce

45import Data.Dependent.Map (DMap, DSum (..))

44import Data.Dependent.Map (DMap, DSum (..))

@@ -54,15 +53,12 @@ import Data.IntMap.Strict (IntMap)

54import qualified Data.IntMap.Strict as IntMap

53import qualified Data.IntMap.Strict as IntMap

55import Data.IORef

54import Data.IORef

56import Data.List hiding (foldl')

55import Data.List hiding (foldl')

57−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

58−import qualified Data.List.NonEmpty as NonEmpty

59import Data.Maybe

56import Data.Maybe

60−import Data.Monoid (mempty, (<>))

57+import Data.Monoid ((<>))

61import Data.Some (Some)

58import Data.Some (Some)

62import qualified Data.Some as Some

59import qualified Data.Some as Some

63import Data.These

60import Data.These

64import Data.Traversable

61import Data.Traversable

65−import Data.Tree (Forest, Tree (..), drawForest)

66import Data.Word

62import Data.Word

67import GHC.IORef (IORef (..))

63import GHC.IORef (IORef (..))

68import GHC.Stack

64import GHC.Stack

@@ -70,6 +66,14 @@ import System.IO.Unsafe

70import System.Mem.Weak

66import System.Mem.Weak

71import Unsafe.Coerce

67import Unsafe.Coerce

69+#ifdef DEBUG_CYCLES

70+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

71+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

72+import qualified Data.List.NonEmpty as NonEmpty

73+import Data.Monoid (mempty)

74+import Data.Tree (Forest, Tree (..), drawForest)

75+#endif

76+

73import Data.WeakBag (WeakBag, WeakBagTicket)

77import Data.WeakBag (WeakBag, WeakBagTicket)

74import qualified Data.WeakBag as WeakBag

78import qualified Data.WeakBag as WeakBag

75import qualified Reflex.Class as R

79import qualified Reflex.Class as R

@@ -188,6 +192,12 @@ unsafeNodeId a = unsafePerformIO $ do

188

192

189newtype Event x a = Event { subscribe :: Subscriber x a -> EventM x (EventSubscription x a) }

193newtype Event x a = Event { subscribe :: Subscriber x a -> EventM x (EventSubscription x a) }

190

194

195+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x a, Maybe a)

196+subscribeAndRead e sub = do

197+ subscription@(EventSubscription _ subd) <- subscribe e sub

198+ occ <- liftIO $ eventSubscribedRead subd

199+ return (subscription, occ)

200+

191wrap :: Monad m => (t -> EventSubscribed x a) -> (Subscriber x a -> m (WeakBagTicket (Subscriber x a), t)) -> Subscriber x a -> m (EventSubscription x a)

201wrap :: Monad m => (t -> EventSubscribed x a) -> (Subscriber x a -> m (WeakBagTicket (Subscriber x a), t)) -> Subscriber x a -> m (EventSubscription x a)

192wrap tag getSpecificSubscribed sub = do

202wrap tag getSpecificSubscribed sub = do

193 (sln, subd) <- getSpecificSubscribed sub

203 (sln, subd) <- getSpecificSubscribed sub

@@ -230,8 +240,7 @@ eventDynIdentity !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent

230subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x a)

240subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x a)

231subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

241subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

232 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

242 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

233− subscription@(EventSubscription _ innerSubd) <- subscribe inner subInner

243+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

234− innerOcc <- liftIO $ readEventSubscribed innerSubd

235 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd

244 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd

236 let height = max innerHeight outerHeight

245 let height = max innerHeight outerHeight

237 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing

246 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing

@@ -298,13 +307,19 @@ newSubscriberMerge k subscribed = return $ Subscriber

298 --TODO: assertions about height

307 --TODO: assertions about height

299 currentHeight <- getCurrentHeight

308 currentHeight <- getCurrentHeight

300 when (height <= currentHeight) $ do

309 when (height <= currentHeight) $ do

301− myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

302 if height /= invalidHeight

310 if height /= invalidHeight

311+ then do

312+ myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

303− then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

313+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

304 else liftIO $ do

314 else liftIO $ do

315+#ifdef DEBUG_CYCLES

305 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

316 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

306 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

317 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

307− error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)

318+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

319+#else

320+ let cycleInfo = ""

321+#endif

322+ error $ "Causality loop found" <> cycleInfo

308 scheduleMerge height subscribed

323 scheduleMerge height subscribed

309 , subscriberInvalidateHeight = \old -> do

324 , subscriberInvalidateHeight = \old -> do

310 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

325 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

@@ -441,10 +456,12 @@ propagate a subscribers = withIncreasedDepth $ do

441data EventSubscribed x a = EventSubscribed

456data EventSubscribed x a = EventSubscribed

442 { eventSubscribedSubscribe :: !(Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a))))

457 { eventSubscribedSubscribe :: !(Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a))))

443 , eventSubscribedRead :: !(IO (Maybe a))

458 , eventSubscribedRead :: !(IO (Maybe a))

444− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

445 , eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

459 , eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

460+#ifdef DEBUG_CYCLES

461+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

446 , eventSubscribedHasOwnHeightRef :: !Bool

462 , eventSubscribedHasOwnHeightRef :: !Bool

447 , eventSubscribedWhoCreated :: !(IO [String])

463 , eventSubscribedWhoCreated :: !(IO [String])

464+#endif

448 }

465 }

449

466

450readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)

467readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)

@@ -457,83 +474,98 @@ eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x a

457eventSubscribedRoot !r = EventSubscribed

474eventSubscribedRoot !r = EventSubscribed

458 { eventSubscribedSubscribe = \sub -> Just <$> subscribeRootSubscribed r sub

475 { eventSubscribedSubscribe = \sub -> Just <$> subscribeRootSubscribed r sub

459 , eventSubscribedRead = readRootSubscribed r

476 , eventSubscribedRead = readRootSubscribed r

460− , eventSubscribedGetParents = return []

461 , eventSubscribedHeightRef = zeroRef

477 , eventSubscribedHeightRef = zeroRef

478+#ifdef DEBUG_CYCLES

479+ , eventSubscribedGetParents = return []

462 , eventSubscribedHasOwnHeightRef = False

480 , eventSubscribedHasOwnHeightRef = False

463 , eventSubscribedWhoCreated = return ["root"]

481 , eventSubscribedWhoCreated = return ["root"]

482+#endif

464 }

483 }

465

484

466eventSubscribedNever :: EventSubscribed x a

485eventSubscribedNever :: EventSubscribed x a

467eventSubscribedNever = EventSubscribed

486eventSubscribedNever = EventSubscribed

468 { eventSubscribedSubscribe = \_ -> return Nothing

487 { eventSubscribedSubscribe = \_ -> return Nothing

469 , eventSubscribedRead = return Nothing

488 , eventSubscribedRead = return Nothing

470− , eventSubscribedGetParents = return []

471 , eventSubscribedHeightRef = zeroRef

489 , eventSubscribedHeightRef = zeroRef

490+#ifdef DEBUG_CYCLES

491+ , eventSubscribedGetParents = return []

472 , eventSubscribedHasOwnHeightRef = False

492 , eventSubscribedHasOwnHeightRef = False

473 , eventSubscribedWhoCreated = return ["never"]

493 , eventSubscribedWhoCreated = return ["never"]

494+#endif

474 }

495 }

475

496

476eventSubscribedPush :: PushSubscribed x b a -> EventSubscribed x a

497eventSubscribedPush :: PushSubscribed x b a -> EventSubscribed x a

477eventSubscribedPush !subscribed = EventSubscribed

498eventSubscribedPush !subscribed = EventSubscribed

478 { eventSubscribedSubscribe = \sub -> Just <$> subscribePushSubscribed subscribed sub

499 { eventSubscribedSubscribe = \sub -> Just <$> subscribePushSubscribed subscribed sub

479 , eventSubscribedRead = readPushSubscribed subscribed

500 , eventSubscribedRead = readPushSubscribed subscribed

480− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]

481 , eventSubscribedHeightRef = pushSubscribedHeight subscribed

501 , eventSubscribedHeightRef = pushSubscribedHeight subscribed

502+#ifdef DEBUG_CYCLES

503+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]

482 , eventSubscribedHasOwnHeightRef = False

504 , eventSubscribedHasOwnHeightRef = False

483 , eventSubscribedWhoCreated = whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed

505 , eventSubscribedWhoCreated = whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed

506+#endif

484 }

507 }

485

508

486eventSubscribedMerge :: a ~ DMap k Identity => MergeSubscribed x k -> EventSubscribed x a

509eventSubscribedMerge :: a ~ DMap k Identity => MergeSubscribed x k -> EventSubscribed x a

487eventSubscribedMerge !subscribed = EventSubscribed

510eventSubscribedMerge !subscribed = EventSubscribed

488 { eventSubscribedSubscribe = \sub -> Just <$> subscribeMergeSubscribed subscribed sub

511 { eventSubscribedSubscribe = \sub -> Just <$> subscribeMergeSubscribed subscribed sub

489 , eventSubscribedRead = readMergeSubscribed subscribed

512 , eventSubscribedRead = readMergeSubscribed subscribed

513+ , eventSubscribedHeightRef = mergeSubscribedHeight subscribed

514+#ifdef DEBUG_CYCLES

490 , eventSubscribedGetParents = do

515 , eventSubscribedGetParents = do

491 ps <- readIORef $ mergeSubscribedParents subscribed

516 ps <- readIORef $ mergeSubscribedParents subscribed

492 return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v

517 return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v

493− , eventSubscribedHeightRef = mergeSubscribedHeight subscribed

494 , eventSubscribedHasOwnHeightRef = True

518 , eventSubscribedHasOwnHeightRef = True

495 , eventSubscribedWhoCreated = whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

519 , eventSubscribedWhoCreated = whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

520+#endif

496 }

521 }

497

522

498eventSubscribedFan :: GCompare k => k a -> FanSubscribed x k -> EventSubscribed x a

523eventSubscribedFan :: GCompare k => k a -> FanSubscribed x k -> EventSubscribed x a

499eventSubscribedFan !k !subscribed = EventSubscribed

524eventSubscribedFan !k !subscribed = EventSubscribed

500 { eventSubscribedSubscribe = \sub -> Just <$> subscribeFanSubscribed k subscribed sub

525 { eventSubscribedSubscribe = \sub -> Just <$> subscribeFanSubscribed k subscribed sub

501 , eventSubscribedRead = readFanSubscribed k subscribed

526 , eventSubscribedRead = readFanSubscribed k subscribed

502− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

503 , eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

527 , eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

528+#ifdef DEBUG_CYCLES

529+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

504 , eventSubscribedHasOwnHeightRef = False

530 , eventSubscribedHasOwnHeightRef = False

505 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

531 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

532+#endif

506 }

533 }

507

534

508eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x a

535eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x a

509eventSubscribedSwitch !subscribed = EventSubscribed

536eventSubscribedSwitch !subscribed = EventSubscribed

510 { eventSubscribedSubscribe = \sub -> Just <$> subscribeSwitchSubscribed subscribed sub

537 { eventSubscribedSubscribe = \sub -> Just <$> subscribeSwitchSubscribed subscribed sub

511 , eventSubscribedRead = readSwitchSubscribed subscribed

538 , eventSubscribedRead = readSwitchSubscribed subscribed

539+ , eventSubscribedHeightRef = switchSubscribedHeight subscribed

540+#ifdef DEBUG_CYCLES

512 , eventSubscribedGetParents = do

541 , eventSubscribedGetParents = do

513 s <- readIORef $ switchSubscribedCurrentParent subscribed

542 s <- readIORef $ switchSubscribedCurrentParent subscribed

514 return [Some.This $ _eventSubscription_subscribed s]

543 return [Some.This $ _eventSubscription_subscribed s]

515− , eventSubscribedHeightRef = switchSubscribedHeight subscribed

516 , eventSubscribedHasOwnHeightRef = True

544 , eventSubscribedHasOwnHeightRef = True

517 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

545 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

546+#endif

518 }

547 }

519

548

520eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x a

549eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x a

521eventSubscribedCoincidence !subscribed = EventSubscribed

550eventSubscribedCoincidence !subscribed = EventSubscribed

522 { eventSubscribedSubscribe = \sub -> Just <$> subscribeCoincidenceSubscribed subscribed sub

551 { eventSubscribedSubscribe = \sub -> Just <$> subscribeCoincidenceSubscribed subscribed sub

523 , eventSubscribedRead = readCoincidenceSubscribed subscribed

552 , eventSubscribedRead = readCoincidenceSubscribed subscribed

553+ , eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed

554+#ifdef DEBUG_CYCLES

524 , eventSubscribedGetParents = do

555 , eventSubscribedGetParents = do

525 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

556 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

526 let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

557 let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

527 innerParents = maybeToList $ fmap Some.This innerSubscription

558 innerParents = maybeToList $ fmap Some.This innerSubscription

528 return $ outerParent : innerParents

559 return $ outerParent : innerParents

529− , eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed

530 , eventSubscribedHasOwnHeightRef = True

560 , eventSubscribedHasOwnHeightRef = True

531 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

561 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

562+#endif

532 }

563 }

533

564

534getEventSubscribedHeight :: EventSubscribed x a -> IO Height

565getEventSubscribedHeight :: EventSubscribed x a -> IO Height

535getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

566getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

536

567

568+#ifdef DEBUG_CYCLES

537whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]

569whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]

538whoCreatedEventSubscribed = eventSubscribedWhoCreated

570whoCreatedEventSubscribed = eventSubscribedWhoCreated

539

571

@@ -547,6 +579,7 @@ walkInvalidHeightParents s0 = do

547 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

579 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

548 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

580 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

549 return subscribers

581 return subscribers

582+#endif

550

583

551{-# INLINE subscribeHoldEvent #-}

584{-# INLINE subscribeHoldEvent #-}

552subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a))

585subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a))

@@ -711,8 +744,7 @@ getHoldEventSubscription h = do

711 Right subd -> return subd

744 Right subd -> return subd

712 Left e -> do

745 Left e -> do

713 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"

746 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"

714− subscription@(EventSubscription _ subd) <- subscribe e =<< liftIO (newSubscriberHold h)

747+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)

715− occ <- liftIO $ readEventSubscribed subd

716 liftIO $ writeIORef subscriptionRef $! subscription

748 liftIO $ writeIORef subscriptionRef $! subscription

717 case occ of

749 case occ of

718 Nothing -> return ()

750 Nothing -> return ()

@@ -1215,6 +1247,7 @@ traceMWhen b getMessage = when b $ do

1215whoCreatedIORef :: IORef a -> IO [String]

1247whoCreatedIORef :: IORef a -> IO [String]

1216whoCreatedIORef (IORef a) = whoCreated $! a

1248whoCreatedIORef (IORef a) = whoCreated $! a

1217

1249

1250+#ifdef DEBUG_CYCLES

1218groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1251groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1219groupByHead = \case

1252groupByHead = \case

1220 [] -> []

1253 [] -> []

@@ -1226,6 +1259,7 @@ groupByHead = \case

1226

1259

1227listsToForest :: Eq a => [[a]] -> Forest a

1260listsToForest :: Eq a => [[a]] -> Forest a

1228listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1261listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1262+#endif

1229

1263

1230{-# INLINE propagateSubscriberHold #-}

1264{-# INLINE propagateSubscriberHold #-}

1231propagateSubscriberHold :: R.Patch p => Hold x p a -> p a -> EventM x ()

1265propagateSubscriberHold :: R.Patch p => Hold x p a -> p a -> EventM x ()

@@ -1428,8 +1462,7 @@ getPushSubscribed p sub = do

1428 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"

1462 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"

1429 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1463 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1430 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe

1464 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe

1431− subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s

1465+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead (pushParent p) s

1432− parentOcc <- liftIO $ readEventSubscribed subd

1433 occ <- runComputeM $ join <$> mapM (pushCompute p) parentOcc

1466 occ <- runComputeM $ join <$> mapM (pushCompute p) parentOcc

1434 occRef <- liftIO $ newIORef occ

1467 occRef <- liftIO $ newIORef occ

1435 when (isJust occ) $ scheduleClear occRef

1468 when (isJust occ) $ scheduleClear occRef

@@ -1476,8 +1509,7 @@ getMergeSubscribed m sub = do

1476 initialParents <- readBehaviorUntracked $ current $ mergeParents m

1509 initialParents <- readBehaviorUntracked $ current $ mergeParents m

1477 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1510 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1478 s <- liftIO $ newSubscriberMerge k subscribedUnsafe

1511 s <- liftIO $ newSubscriberMerge k subscribedUnsafe

1479− subscription@(EventSubscription _ parentSubd) <- subscribe e s

1512+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1480− parentOcc <- liftIO $ readEventSubscribed parentSubd

1481 height <- liftIO $ getEventSubscribedHeight parentSubd

1513 height <- liftIO $ getEventSubscribedHeight parentSubd

1482 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)

1514 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)

1483 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1515 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

@@ -1605,12 +1637,11 @@ getSwitchSubscribed s sub = do

1605 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior

1637 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior

1606 holdInits <- getDeferralQueue

1638 holdInits <- getDeferralQueue

1607 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits

1639 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits

1608− subscription@(EventSubscription _ subd) <- subscribe e mySub

1640+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub

1609− parentOcc <- liftIO $ readEventSubscribed subd

1641+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd

1610 subscriptionRef <- liftIO $ newIORef subscription

1642 subscriptionRef <- liftIO $ newIORef subscription

1611 occRef <- liftIO $ newIORef parentOcc

1643 occRef <- liftIO $ newIORef parentOcc

1612 when (isJust parentOcc) $ scheduleClear occRef

1644 when (isJust parentOcc) $ scheduleClear occRef

1613− heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd

1614 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1645 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1615 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1646 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1616 let !subscribed = SwitchSubscribed

1647 let !subscribed = SwitchSubscribed

@@ -1655,8 +1686,7 @@ getCoincidenceSubscribed c sub = do

1655 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"

1686 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"

1656 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1687 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1657 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe

1688 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe

1658− outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter

1689+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter

1659− outerOcc <- liftIO $ readEventSubscribed outerSubd

1660 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd

1690 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd

1661 (occ, height, mInnerSubd) <- case outerOcc of

1691 (occ, height, mInnerSubd) <- case outerOcc of

1662 Nothing -> return (Nothing, outerHeight, Nothing)

1692 Nothing -> return (Nothing, outerHeight, Nothing)

@@ -1731,8 +1761,7 @@ initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1731initMerge :: SomeMergeInit x -> EventM x ()

1761initMerge :: SomeMergeInit x -> EventM x ()

1732initMerge (SomeMergeInit subscribed changed) = do

1762initMerge (SomeMergeInit subscribed changed) = do

1733 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1763 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1734− EventSubscription _ changeSubd <- subscribe changed changeSub

1764+ (EventSubscription _ changeSubd, change) <- subscribeAndRead changed changeSub

1735− change <- liftIO $ readEventSubscribed changeSubd

1736 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1765 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1737 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

1766 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

1738

1767

@@ -1779,8 +1808,8 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1779 Just e -> do

1808 Just e -> do

1780 s <- liftIO $ newSubscriberMerge k m

1809 s <- liftIO $ newSubscriberMerge k m

1781 subscription@(EventSubscription _ subd) <- subscribe e s

1810 subscription@(EventSubscription _ subd) <- subscribe e s

1782− let newParent = MergeSubscribedParent subscription s

1783 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1811 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1812+ let newParent = MergeSubscribedParent subscription s

1784 liftIO $ addMergeHeight newParentHeight m

1813 liftIO $ addMergeHeight newParentHeight m

1785 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1814 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1786 forM_ mOldSubd $ \oldSubd -> do

1815 forM_ mOldSubd $ \oldSubd -> do

@@ -1849,10 +1878,12 @@ zeroHeight = Height 0

1849invalidHeight :: Height

1878invalidHeight :: Height

1850invalidHeight = Height (-1000)

1879invalidHeight = Height (-1000)

1851

1880

1881+#ifdef DEBUG_CYCLES

1852-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents

1882-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents

1853{-# INLINE invalidHeightBeingTraversed #-}

1883{-# INLINE invalidHeightBeingTraversed #-}

1854invalidHeightBeingTraversed :: Height

1884invalidHeightBeingTraversed :: Height

1855invalidHeightBeingTraversed = Height (-1001)

1885invalidHeightBeingTraversed = Height (-1001)

1886+#endif

1856

1887

1857{-# INLINE succHeight #-}

1888{-# INLINE succHeight #-}

1858succHeight :: Height -> Height

1889succHeight :: Height -> Height

@@ -2104,20 +2135,28 @@ instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where

2104 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . DynamicHold <$> hold v0 e

2135 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . DynamicHold <$> hold v0 e

2105

2136

2106data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2137data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2107−newtype SpiderEventHandle x a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription x a }

2108

2138

2109−emptySubscriber :: Subscriber x a

2139+data SpiderEventHandle x a = SpiderEventHandle

2110−emptySubscriber = Subscriber

2140+ { spiderEventHandleSubscription :: EventSubscription x a

2111− { subscriberPropagate = \_ -> return ()

2141+ , spiderEventHandleValue :: IORef (Maybe a)

2112− , subscriberInvalidateHeight = \_ -> return ()

2113− , subscriberRecalculateHeight = \_ -> return ()

2114 }

2142 }

2115

2143

2116instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where

2144instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where

2117 {-# INLINABLE subscribeEvent #-}

2145 {-# INLINABLE subscribeEvent #-}

2118 subscribeEvent e = SpiderHostFrame $ do

2146 subscribeEvent e = SpiderHostFrame $ do

2119− subscription <- subscribe (unSpiderEvent e) emptySubscriber --TODO: Unsubscribe eventually (manually and/or with weak ref)

2147+ --TODO: Unsubscribe eventually (manually and/or with weak ref)

2148+ val <- liftIO $ newIORef Nothing

2149+ subscription <- subscribe (unSpiderEvent e) $ Subscriber

2150+ { subscriberPropagate = \a -> do

2151+ liftIO $ writeIORef val $ Just a

2152+ scheduleClear val

2153+ , subscriberInvalidateHeight = \_ -> return ()

2154+ , subscriberRecalculateHeight = \_ -> return ()

2155+ }

2120− return $ SpiderEventHandle subscription

2156+ return $ SpiderEventHandle

2157+ { spiderEventHandleSubscription = subscription

2158+ , spiderEventHandleValue = val

2159+ }

2121

2160

2122instance R.ReflexHost (SpiderEnv x) where

2161instance R.ReflexHost (SpiderEnv x) where

2123 type EventTrigger (SpiderEnv x) = RootTrigger x

2162 type EventTrigger (SpiderEnv x) = RootTrigger x

@@ -2127,10 +2166,8 @@ instance R.ReflexHost (SpiderEnv x) where

2127instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2166instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2128 {-# INLINABLE readEvent #-}

2167 {-# INLINABLE readEvent #-}

2129 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2168 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2130− let EventSubscription sln subscribed = unSpiderEventHandle h

2131− result <- readEventSubscribed subscribed

2132− touch sln

2169+ touch h

2133− return result

2170+ readIORef $ spiderEventHandleValue h

2134

2171

2135instance MonadRef (EventM x) where

2172instance MonadRef (EventM x) where

2136 type Ref (EventM x) = Ref IO

2173 type Ref (EventM x) = Ref IO

@@ -2220,12 +2257,7 @@ instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where

2220

2257

2221instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where

2258instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where

2222 {-# INLINABLE subscribeEvent #-}

2259 {-# INLINABLE subscribeEvent #-}

2223− subscribeEvent = subscribeEventSpiderHost

2260+ subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

2224−

2225−subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)

2226−subscribeEventSpiderHost e = do

2227− subscription <- runFrame $ subscribe (unSpiderEvent e) emptySubscriber --TODO: Unsubscribe eventually (manually and/or with weak ref)

2228− return $ SpiderEventHandle subscription

2229

2261

2230newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2262newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2231

2263