fa5c17f · reflex · git.iko.soy

129

130instance HasNodeId (CacheSubscribed x a) where

131 getNodeId = _cacheSubscribed_nodeId

132−

132+

133instance HasNodeId (FanInt x a) where

134 getNodeId = _fanInt_nodeId

135

156showNodeId = showNodeId' . getNodeId

157

158showNodeId' :: Int -> String

159−showNodeId' = ("#"<>) . show

159+showNodeId' = ("#"<>) . show

160

161

162#else

253 let clearParent = liftIO $ writeIORef parent Nothing

254 (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent

255 when (isJust occ) clearParent

256− return $ Event $ \sub ->

256+ return $ Event $ \sub ->

257 liftIO (readIORef parent) >>= \case

258− Nothing -> subscribeAndReadNever

258+ Nothing -> subscribeAndReadNever

259 Just e -> subscribeAndReadHead e sub

260

261data CacheSubscribed x a

305 liftIO $ writeIORef occRef (Just a)

306 scheduleClear occRef

307 propagateFast a subscribers

308− , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight

308+ , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight

309− , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight

309+ , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight

310 }

311||||||| merged common ancestors

312 (parentSub, occ) <- subscribeAndRead e $ Subscriber

340 , _cacheSubscribed_occurrence = occRef

341#ifdef DEBUG_NODEIDS

342 , _cacheSubscribed_nodeId = nodeId

343−#endif

343+#endif

344 }

345 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

346 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

347 return subscribedTicket

348 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

349

350−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

350+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

351 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)

352−cacheSubscription sub mSubscribedRef subscribedTicket = do

352+cacheSubscription sub mSubscribedRef subscribedTicket = do

353 subscribed <- getFastWeakTicketValue subscribedTicket

354 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

355 occ <- readIORef $ _cacheSubscribed_occurrence subscribed

356−

356+

357 let parentSub = _cacheSubscribed_parent subscribed

358 es = EventSubscription

359 { _eventSubscription_unsubscribe = do

372 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

373 , eventSubscribedHasOwnHeightRef = False

374 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

375−#endif

375+#endif

376 }

377− }

377+ }

378 return (es, occ)

379

380

495 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

496 scheduleClear $ coincidenceSubscribedInnerParent subscribed

497 case occ of

498− Nothing ->

498+ Nothing ->

499 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

500 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

501 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

505 scheduleClear $ coincidenceSubscribedOccurrence subscribed

506 propagate o $ coincidenceSubscribedSubscribers subscribed

507 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

508− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

508+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

509 }

510

511newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

526invalidateSubscriberHeight = flip subscriberInvalidateHeight

527

528recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

529−recalculateSubscriberHeight = flip subscriberRecalculateHeight

529+recalculateSubscriberHeight = flip subscriberRecalculateHeight

530

531-- | Propagate everything at the current height

532propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

533−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

533+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

534 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

535 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

536 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

537

538-- | Propagate everything at the current height

539propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

540−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

540+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

541 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

542 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

543 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

1023newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1024

1025-- EventM can do everything BehaviorM can, plus create holds

1026−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

1026+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

1027

1028newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1029

1048heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1049

1050heightBagAdd :: Height -> HeightBag -> HeightBag

1051−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

1051+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

1052 IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1053

1054heightBagRemove :: Height -> HeightBag -> HeightBag

1059 _ -> IntMap.insert h (pred old) c

1060

1061heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag

1062−heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where

1062+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where

1063 removed old = HeightBag (pred s) $ case old of

1064 0 -> IntMap.delete h c

1065 _ -> IntMap.insert h (pred old) c

1066−

1066+

1067

1068heightBagMax :: HeightBag -> Height

1069heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1328debugSubscriber description = return . debugSubscriber' description

1329

1330debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a

1331−debugSubscriber' description subscribed = Subscriber

1331+debugSubscriber' description subscribed = Subscriber

1332 {

1333 subscriberPropagate = \m -> do

1334 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1430

1431#ifdef DEBUG_CYCLES

1432

1433−data EventLoopException = EventLoopException [[String]]

1433+data EventLoopException = EventLoopException [[String]]

1434instance Exception EventLoopException

1435

1436instance Show EventLoopException where

1437− show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1437+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1438− then "no location information, compile with profiling enabled for stack tree"

1438+ then "no location information, compile with profiling enabled for stack tree"

1439 else showStacks stacks

1440

1441#else

1461 case {-# SCC "apply" #-} apply a v of

1462 Nothing -> return ()

1463 Just v' -> do

1464− withIncreasedDepth (Proxy :: Proxy x) $

1464+ withIncreasedDepth (Proxy :: Proxy x) $

1465 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1466 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1467 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1582 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1583 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1584 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1585−#ifdef DEBUG_NODEIDS

1585+#ifdef DEBUG_NODEIDS

1586 , _fanInt_nodeId :: {-# UNPACK #-} !Int

1587#endif

1588 }

1592 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1593 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1594 occRef <- newIORef $ error "fanInt: no occurrence"

1595−#ifdef DEBUG_NODEIDS

1595+#ifdef DEBUG_NODEIDS

1596 nodeId <- newNodeId

1597#endif

1598 return $ FanInt

1599 { _fanInt_subscribers = subscribers

1600 , _fanInt_subscriptionRef = subscriptionRef

1601 , _fanInt_occRef = occRef

1602−#ifdef DEBUG_NODEIDS

1602+#ifdef DEBUG_NODEIDS

1603− , _fanInt_nodeId = nodeId

1603+ , _fanInt_nodeId = nodeId

1604#endif

1605 }

1606

1616 liftIO $ writeIORef (_fanInt_occRef self) m

1617 scheduleIntClear $ _fanInt_occRef self

1618 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1619− FastWeakBag.traverse_ b $ \s ->

1619+ FastWeakBag.traverse_ b $ \s ->

1620 subscriberPropagate s v

1621− , subscriberInvalidateHeight = \old ->

1621+ , subscriberInvalidateHeight = \old ->

1622− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1622+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1623− FastWeakBag.traverse_ b $ \s ->

1623+ FastWeakBag.traverse_ b $ \s ->

1624 subscriberInvalidateHeight s old

1625 , subscriberRecalculateHeight = \new ->

1626− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1626+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1627− FastWeakBag.traverse_ b $ \s ->

1627+ FastWeakBag.traverse_ b $ \s ->

1628 subscriberRecalculateHeight s new

1629 }

1630 liftIO $ do

1640 Just b -> return b

1641 ticket <- liftIO $ FastWeakBag.insert sub b

1642 currentOcc <- readIORef (_fanInt_occRef self)

1643−

1643+

1644 subscribed <- fanIntSubscribed ticket self

1645 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1646

1647fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1648−fanIntSubscribed ticket self = do

1648+fanIntSubscribed ticket self = do

1649 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1650− return $ EventSubscribed

1650+ return $ EventSubscribed

1651 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1652 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1653#ifdef DEBUG_CYCLES

1656 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1657#endif

1658 }

1659−

1659+

1660

1661{-# INLINABLE getFanSubscribed #-}

1662getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

1869 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

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

1871 forM_ mOldSubd $ \oldSubd -> do

1872− oldHeight <- liftIO $ getEventSubscribedHeight $

1872+ oldHeight <- liftIO $ getEventSubscribedHeight $

1873 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1874

1875 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1915 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1916 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1917 Nothing -> do

1918− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1918+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1919 _mergeSubscribedParentWithMove_subscription parent

1920

1921 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1923 Just toKey -> do

1924 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1925 return Nothing

1926− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1926+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1927 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1928

1929 return (toDelete, applyAlways p' oldParents)

1976invalidateMergeHeight' heightRef sub = do

1977 oldHeight <- readIORef heightRef

1978 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1979− when (oldHeight /= invalidHeight) $ do

1979+ when (oldHeight /= invalidHeight) $ do

1980 writeIORef heightRef $! invalidHeight

1981 subscriberInvalidateHeight sub oldHeight

1982

1983revalidateMergeHeight :: Merge x k v s -> IO ()

1984revalidateMergeHeight m = do

1985 currentHeight <- readIORef $ _merge_heightRef m

1986−

1986+

1987 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1988− when (currentHeight == invalidHeight) $ do

1988+ when (currentHeight == invalidHeight) $ do

1989 heights <- readIORef $ _merge_heightBagRef m

1990 parents <- readIORef $ _merge_parentsRef m

1991 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

2001scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

2002scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

2003 vals <- liftIO $ readIORef $ _merge_accumRef m

2004− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2004+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2005 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2006− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

2006+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

2007 --TODO: Assert that m is not empty

2008 subscriberPropagate (_merge_sub m) vals

2009

2010checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()

2011checkCycle subscribed = liftIO $ do

2012 height <- readIORef (eventSubscribedHeightRef subscribed)

2013−

2013+

2014 -- currentHeight <- getCurrentHeight

2015 -- when (height <= currentHeight) $ if height /= invalidHeight

2016 -- then do

2017 -- myStack <- liftIO $ whoCreatedIORef undefined --TODO

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

2019− -- else liftIO $

2019+ -- else liftIO $

2020 when (height == invalidHeight) $

2021#ifdef DEBUG_CYCLES

2022 do

2069 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2070 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2071

2072− let subscribed = EventSubscribed

2072+ let subscribed = EventSubscribed

2073− { eventSubscribedHeightRef = heightRef

2073+ { eventSubscribedHeightRef = heightRef

2074 , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

2075#ifdef DEBUG_CYCLES

2076 , eventSubscribedGetParents = do

2077 let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)

2078− fmap getParent' . DMap.toList <$> readIORef parentsRef

2078+ fmap getParent' . DMap.toList <$> readIORef parentsRef

2079 , eventSubscribedHasOwnHeightRef = False

2080 , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2081−#endif

2081+#endif

2082− }

2082+ }

2083

2084 m = Merge

2085 { _merge_parentsRef = parentsRef

2117 -- its subscription.

2118 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2119 let unsubscribeAll = destroy =<< readIORef parentsRef

2120−

2120+

2121 return (EventSubscription unsubscribeAll subscribed, occ)

2122−

2122+

2123

2124mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2125mergeInt = cacheEvent . mergeIntCheap

2133 heightBagRef <- liftIO $ newIORef heightBagEmpty

2134 parents <- liftIO $ FastMutableIntMap.newEmpty

2135 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2136− let subscribed = EventSubscribed

2136+ let subscribed = EventSubscribed

2137− { eventSubscribedHeightRef = heightRef

2137+ { eventSubscribedHeightRef = heightRef

2138 , eventSubscribedRetained = toAny (parents, changeSubdRef)

2139#ifdef DEBUG_CYCLES

2140 , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents

2141 , eventSubscribedHasOwnHeightRef = False

2142 , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2143−#endif

2143+#endif

2144 }

2145 let scheduleSelf = do

2146 height <- liftIO $ readIORef $ heightRef

2229 -- its subscription.

2230 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2231 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2232−

2232+

2233

2234 return (EventSubscription unsubscribeAll subscribed, occ)

2235