1{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiWayIf #-}
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RoleAnnotations #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE PolyKinds #-}
20{-# LANGUAGE DeriveFunctor #-}
21{-# LANGUAGE StandaloneDeriving #-}
22{-# LANGUAGE InstanceSigs #-}
24#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
27{-# OPTIONS_GHC -Wunused-binds #-}
28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
32#if MIN_VERSION_base(4,10,0)
33import Control.Applicative (liftA2)
35import Control.Concurrent
36import Control.Exception
37import Control.Monad hiding (forM, forM_, mapM, mapM_)
38import Control.Monad.Exception
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Primitive
41import Control.Monad.Reader.Class
42import Control.Monad.IO.Class
43import Control.Monad.ReaderIO
44import Control.Monad.Ref
45import Control.Monad.Fail (MonadFail)
46import qualified Control.Monad.Fail as MonadFail
49import Data.Dependent.Map (DMap, DSum (..))
50import qualified Data.Dependent.Map as DMap
51import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
52import qualified Data.FastMutableIntMap as FastMutableIntMap
53import Data.Foldable hiding (concat, elem, sequence_)
54import Data.Functor.Constant
55import Data.Functor.Misc
56import Data.Functor.Product
57import Data.GADT.Compare
58import Data.IntMap.Strict (IntMap)
59import qualified Data.IntMap.Strict as IntMap
61import Data.Kind (Type)
62import Data.Maybe hiding (mapMaybe)
63import Data.Monoid (mempty, (<>))
66import Data.Traversable
67import Data.Type.Equality ((:~:)(Refl))
68import Data.Witherable (Filterable, mapMaybe)
69import GHC.Exts hiding (toList)
70import GHC.IORef (IORef (..))
73import System.IO.Unsafe
77#ifdef MIN_VERSION_semialign
78#if MIN_VERSION_these(0,8,0)
79import Data.These.Combinators (justThese)
81#if MIN_VERSION_semialign(1,1,0)
82import Data.Zip (Zip (..))
87import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
90import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
91import qualified Data.List.NonEmpty as NonEmpty
92import Data.Tree (Forest, Tree (..), drawForest)
93import Data.List (isPrefixOf)
95import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
96import qualified Data.FastWeakBag as FastWeakBag
99import Data.Some (Some(Some))
100import Data.Type.Coercion
101import Data.Profunctor.Unsafe ((#.), (.#))
102import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
103import qualified Data.WeakBag as WeakBag
104import qualified Reflex.Class
105import qualified Reflex.Class as R
106import qualified Reflex.Host.Class
107import Reflex.NotReady.Class
109import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
110import Reflex.PerformEvent.Base (PerformEventT)
112#ifdef DEBUG_TRACE_EVENTS
113import qualified Data.ByteString.Char8 as BS8
114import System.IO (stderr)
115import Data.List (isPrefixOf)
118-- TODO stdout might not be the best channel for debug output
119debugStrLn :: String -> IO ()
122#ifdef DEBUG_TRACE_EVENTS
123withStackOneLine :: (BS8.ByteString -> a) -> a
124withStackOneLine expr = unsafePerformIO $ do
125 stack <- currentCallStack
126 return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
127 where dropInternal = filterStack "Reflex.Spider.Internal"
131debugPropagate :: Bool
133debugInvalidateHeight :: Bool
135debugInvalidate :: Bool
140#ifdef DEBUG_TRACE_PROPAGATION
143debugPropagate = False
146#ifdef DEBUG_TRACE_HEIGHT
147debugInvalidateHeight = True
149debugInvalidateHeight = False
152#ifdef DEBUG_TRACE_INVALIDATION
153debugInvalidate = True
155debugInvalidate = False
158class HasNodeId a where
159 getNodeId :: a -> Int
161instance HasNodeId (CacheSubscribed x a) where
162 getNodeId = _cacheSubscribed_nodeId
164instance HasNodeId (FanInt x a) where
165 getNodeId = _fanInt_nodeId
167instance HasNodeId (Hold x p) where
168 getNodeId = holdNodeId
170instance HasNodeId (SwitchSubscribed x a) where
171 getNodeId = switchSubscribedNodeId
173instance HasNodeId (FanSubscribed x v a) where
174 getNodeId = fanSubscribedNodeId
176instance HasNodeId (CoincidenceSubscribed x a) where
177 getNodeId = coincidenceSubscribedNodeId
179instance HasNodeId (RootSubscribed x a) where
180 getNodeId = rootSubscribedNodeId
182instance HasNodeId (Pull x a) where
183 getNodeId = pullNodeId
185{-# INLINE showNodeId #-}
186showNodeId :: HasNodeId a => a -> String
187showNodeId = showNodeId' . getNodeId
189showNodeId' :: Int -> String
190showNodeId' = ("#"<>) . show
195debugPropagate = False
196debugInvalidateHeight = False
197debugInvalidate = False
199-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
200{-# INLINE showNodeId #-}
201showNodeId :: a -> String
204{-# INLINE showNodeId' #-}
205showNodeId' :: Int -> String
211{-# NOINLINE nextNodeIdRef #-}
212nextNodeIdRef :: IORef Int
213nextNodeIdRef = unsafePerformIO $ newIORef 1
216newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
219--------------------------------------------------------------------------------
221--------------------------------------------------------------------------------
223--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
224-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
225data EventSubscription x = EventSubscription
226 { _eventSubscription_unsubscribe :: !(IO ())
227 , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
230unsubscribe :: EventSubscription x -> IO ()
231unsubscribe (EventSubscription u _) = u
233--------------------------------------------------------------------------------
235--------------------------------------------------------------------------------
237newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
239{-# INLINE subscribeAndRead #-}
240subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
241subscribeAndRead = unEvent
244"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
245"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
246"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
249-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
250-- caching; if the computation function is very cheap, this is (much) more
251-- efficient than 'push'
252{-# INLINE [1] pushCheap #-}
253pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
254pushCheap !f e = Event $ \sub -> do
255 (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
256 { subscriberPropagate = \a -> do
258 mapM_ (subscriberPropagate sub) mb
260 occ' <- join <$> mapM f occ
261 return (subscription, occ')
263-- | A subscriber that never triggers other 'Event's
264{-# INLINE terminalSubscriber #-}
265terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
266terminalSubscriber p = Subscriber
267 { subscriberPropagate = p
268 , subscriberInvalidateHeight = \_ -> return ()
269 , subscriberRecalculateHeight = \_ -> return ()
272-- | Subscribe to an Event only for the duration of one occurrence
273{-# INLINE subscribeAndReadHead #-}
274subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
275subscribeAndReadHead e sub = do
276 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
277 (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub
278 { subscriberPropagate = \a -> do
279 liftIO $ unsubscribe =<< readIORef subscriptionRef
280 subscriberPropagate sub a
283 Nothing -> writeIORef subscriptionRef $! subscription
284 Just _ -> unsubscribe subscription
285 return (subscription, occ)
287--TODO: Make this lazy in its input event
288headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)
290 parent <- liftIO $ newIORef $ Just originalE
291 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
292 let clearParent = liftIO $ writeIORef parent Nothing
293 (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
294 when (isJust occ) clearParent
295 return $ Event $ \sub ->
296 liftIO (readIORef parent) >>= \case
297 Nothing -> subscribeAndReadNever
298 Just e -> subscribeAndReadHead e sub
300data CacheSubscribed x a
301 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
302 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
303 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
305 , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int
311-- | Construct an 'Event' whose value is guaranteed not to be recomputed
314--TODO: Try a caching strategy where we subscribe directly to the parent when
315--there's only one subscriber, and then build our own FastWeakBag only when a second
317{-# NOINLINE [0] cacheEvent #-}
318cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
320#ifdef DEBUG_TRACE_EVENTS
321 withStackOneLine $ \callSite -> Event $
326 mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
327 <- newIORef emptyFastWeak
328 pure $ \sub -> {-# SCC "cacheEvent" #-} do
329#ifdef DEBUG_TRACE_EVENTS
330 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
332 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
333 Just subscribedTicket -> return subscribedTicket
336 nodeId <- liftIO newNodeId
338 subscribers <- liftIO FastWeakBag.empty
339 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
341 (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber
343 (parentSub, occ) <- subscribeAndRead e $ Subscriber
345 { subscriberPropagate = \a -> do
346 liftIO $ writeIORef occRef (Just a)
348 propagateFast a subscribers
349 , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight
350 , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight
352 when (isJust occ) $ do
353 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
355 let !subscribed = CacheSubscribed
356 { _cacheSubscribed_subscribers = subscribers
357 , _cacheSubscribed_parent = parentSub
358 , _cacheSubscribed_occurrence = occRef
360 , _cacheSubscribed_nodeId = nodeId
363 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
364 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
365 return subscribedTicket
366 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
368cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
369 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
370cacheSubscription sub mSubscribedRef subscribedTicket = do
371 subscribed <- getFastWeakTicketValue subscribedTicket
372 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
373 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
375 let parentSub = _cacheSubscribed_parent subscribed
376 es = EventSubscription
377 { _eventSubscription_unsubscribe = do
378 FastWeakBag.remove ticket
380 isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
382 writeIORef mSubscribedRef emptyFastWeak
383 unsubscribe parentSub
385 touch subscribedTicket
386 , _eventSubscription_subscribed = EventSubscribed
387 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub
388 , eventSubscribedRetained = toAny subscribedTicket
390 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
391 , eventSubscribedHasOwnHeightRef = False
392 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
399subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
400subscribe e s = fst <$> subscribeAndRead e s
403wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
404wrap tag getSpecificSubscribed sub = do
405 (sln, subd, occ) <- getSpecificSubscribed sub
407 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
409eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
410eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
412subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
413subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
415eventNever :: Event x a
416eventNever = Event $ const subscribeAndReadNever
418eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
419eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
421eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
422eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
424eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
425eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
427eventHold :: Hold x p -> Event x p
428eventHold !h = Event $ subscribeHoldEvent h
430eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
431eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
433{-# INLINE subscribeCoincidenceInner #-}
434subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)
435subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
436 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
437 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
438 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
439 let height = max innerHeight outerHeight
440 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
441 return (innerOcc, height, innerSubd)
443--------------------------------------------------------------------------------
445--------------------------------------------------------------------------------
447data Subscriber x a = Subscriber
448 { subscriberPropagate :: !(a -> EventM x ())
449 , subscriberInvalidateHeight :: !(Height -> IO ())
450 , subscriberRecalculateHeight :: !(Height -> IO ())
453--TODO: Move this comment to WeakBag
454-- These function are constructor functions that are marked NOINLINE so they are
455-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
456-- so any weak references that are attached to the constructors will have their
457-- finalizer run. Using the opaque constructor, does not see the
458-- constructor application, so it behaves like an IORef and cannot be fused away.
460-- The result is also evaluated to WHNF, since forcing a thunk invalidates
461-- the weak pointer to it in some cases.
463newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
464newSubscriberHold h = return $ Subscriber
465 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
466 , subscriberInvalidateHeight = \_ -> return ()
467 , subscriberRecalculateHeight = \_ -> return ()
470newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
471newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
472 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
473 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
474 tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
475 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
476 scheduleClear $ fanSubscribedOccurrence subscribed
477 let f _ (Pair v subsubs) = do
478 propagate v $ _fanSubscribedChildren_list subsubs
480 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
482 , subscriberInvalidateHeight = \old -> do
483 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
484 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
485 , subscriberRecalculateHeight = \new -> do
486 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
487 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
490newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
491newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
492 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
493 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
494 scheduleClear $ switchSubscribedOccurrence subscribed
495 propagate a $ switchSubscribedSubscribers subscribed
496 , subscriberInvalidateHeight = \_ -> do
497 oldHeight <- readIORef $ switchSubscribedHeight subscribed
498 when (oldHeight /= invalidHeight) $ do
499 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
500 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
501 , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
504newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
505newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
506 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
507 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
508 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
509 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
510 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
511 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
513 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
514 scheduleClear $ coincidenceSubscribedInnerParent subscribed
517 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
518 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
519 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
520 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
521 Just o -> do -- Since it's already firing, no need to adjust height
522 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
523 scheduleClear $ coincidenceSubscribedOccurrence subscribed
524 propagate o $ coincidenceSubscribedSubscribers subscribed
525 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
526 , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
529newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
530newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber
531 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
532 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
534 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
536 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
537 scheduleClear $ coincidenceSubscribedOccurrence subscribed
538 propagate a $ coincidenceSubscribedSubscribers subscribed
539 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
540 , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
543invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
544invalidateSubscriberHeight = flip subscriberInvalidateHeight
546recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
547recalculateSubscriberHeight = flip subscriberRecalculateHeight
549-- | Propagate everything at the current height
550propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
551propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
552 -- 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
553 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
554 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
556-- | Propagate everything at the current height
557propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
558propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
559 -- 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
560 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
561 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
563--------------------------------------------------------------------------------
565--------------------------------------------------------------------------------
570-- Why do we use Any here, instead of just giving eventSubscribedRetained an
571-- existential type? Sadly, GHC does not currently know how to unbox types
572-- with existentially quantified fields. So instead we just coerce values
573-- to type Any on the way in. Since we never coerce them back, this is
575data EventSubscribed x = EventSubscribed
576 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
577 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
579 , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
580 , eventSubscribedHasOwnHeightRef :: !Bool
581 , eventSubscribedWhoCreated :: !(IO [String])
585eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
586eventSubscribedRoot !r = EventSubscribed
587 { eventSubscribedHeightRef = zeroRef
588 , eventSubscribedRetained = toAny r
590 , eventSubscribedGetParents = return []
591 , eventSubscribedHasOwnHeightRef = False
592 , eventSubscribedWhoCreated = return ["root"]
596eventSubscribedNever :: EventSubscribed x
597eventSubscribedNever = EventSubscribed
598 { eventSubscribedHeightRef = zeroRef
599 , eventSubscribedRetained = toAny ()
601 , eventSubscribedGetParents = return []
602 , eventSubscribedHasOwnHeightRef = False
603 , eventSubscribedWhoCreated = return ["never"]
607eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
608eventSubscribedFan !subscribed = EventSubscribed
609 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
610 , eventSubscribedRetained = toAny subscribed
612 , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
613 , eventSubscribedHasOwnHeightRef = False
614 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
618eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
619eventSubscribedSwitch !subscribed = EventSubscribed
620 { eventSubscribedHeightRef = switchSubscribedHeight subscribed
621 , eventSubscribedRetained = toAny subscribed
623 , eventSubscribedGetParents = do
624 s <- readIORef $ switchSubscribedCurrentParent subscribed
625 return [_eventSubscription_subscribed s]
626 , eventSubscribedHasOwnHeightRef = True
627 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
631eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
632eventSubscribedCoincidence !subscribed = EventSubscribed
633 { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
634 , eventSubscribedRetained = toAny subscribed
636 , eventSubscribedGetParents = do
637 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
638 let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
639 innerParents = maybeToList $ innerSubscription
640 return $ outerParent : innerParents
641 , eventSubscribedHasOwnHeightRef = True
642 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
646getEventSubscribedHeight :: EventSubscribed x -> IO Height
647getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
650whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
651whoCreatedEventSubscribed = eventSubscribedWhoCreated
653walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
654walkInvalidHeightParents s0 = do
655 subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
656 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
657 when (h == invalidHeight) $ do
658 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
660 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
661 forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
665{-# INLINE subscribeHoldEvent #-}
666subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
667subscribeHoldEvent = subscribeAndRead . holdEvent
669--------------------------------------------------------------------------------
671--------------------------------------------------------------------------------
673newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
675behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
676behaviorHold !h = Behavior $ readHoldTracked h
678behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
679behaviorHoldIdentity = behaviorHold
681behaviorConst :: a -> Behavior x a
682behaviorConst !a = Behavior $ return a
684behaviorPull :: Pull x a -> Behavior x a
685behaviorPull !p = Behavior $ do
686 val <- liftIO $ readIORef $ pullValue p
688 Just subscribed -> do
689 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
690 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
691 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
692 return $ pullSubscribedValue subscribed
694 i <- liftIO $ newInvalidatorPull p
695 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
696 parentsRef <- liftIO $ newIORef []
697 holdInits <- askBehaviorHoldInits
698 a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
699 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
700 parents <- liftIO $ readIORef parentsRef
701 let subscribed = PullSubscribed
702 { pullSubscribedValue = a
703 , pullSubscribedInvalidators = invsRef
704 , pullSubscribedOwnInvalidator = i
705 , pullSubscribedParents = parents
707 liftIO $ writeIORef (pullValue p) $ Just subscribed
708 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
711behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
712behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
714{-# INLINE readHoldTracked #-}
715readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
716readHoldTracked h = do
717 result <- liftIO $ readIORef $ holdValue h
718 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
719 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
720 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
723{-# INLINABLE readBehaviorUntracked #-}
724readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
725readBehaviorUntracked b = do
726 holdInits <- getDeferralQueue
727 liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
729--------------------------------------------------------------------------------
731--------------------------------------------------------------------------------
733type DynamicS x p = Dynamic x (PatchTarget p) p
735data Dynamic x target p = Dynamic
736 { dynamicCurrent :: !(Behavior x target)
737 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
740deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
745dynamicHold :: Hold x p -> DynamicS x p
746dynamicHold !h = Dynamic
747 { dynamicCurrent = behaviorHold h
748 , dynamicUpdated = eventHold h
751dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
752dynamicHoldIdentity = dynamicHold
754dynamicConst :: PatchTarget p -> DynamicS x p
755dynamicConst !a = Dynamic
756 { dynamicCurrent = behaviorConst a
757 , dynamicUpdated = eventNever
760dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
761dynamicDyn !d = Dynamic
762 { dynamicCurrent = behaviorDyn d
763 , dynamicUpdated = eventDyn d
766dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
767dynamicDynIdentity = dynamicDyn
769--------------------------------------------------------------------------------
771--------------------------------------------------------------------------------
773--type role Hold representational
775 = Hold { holdValue :: !(IORef (PatchTarget p))
776 , holdInvalidators :: !(IORef [Weak (Invalidator x)])
777 , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
778 , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
784-- | A statically allocated 'SpiderTimeline'
787{-# NOINLINE globalSpiderTimelineEnv #-}
788globalSpiderTimelineEnv :: SpiderTimelineEnv Global
789globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
791-- | Stores all global data relevant to a particular Spider timeline; only one
792-- value should exist for each type @x@
793newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
794-- We implement SpiderTimelineEnv with a newtype wrapper so
795-- we can get the coercions we want safely.
796type role SpiderTimelineEnv nominal
798data SpiderTimelineEnv' x = SpiderTimelineEnv
799 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
800 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
802 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
805type role SpiderTimelineEnv' phantom
807instance Eq (SpiderTimelineEnv x) where
808 _ == _ = True -- Since only one exists of each type
810instance GEq SpiderTimelineEnv where
811 a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
812 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
816 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
817 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
818 , eventEnvDynInits :: !(IORef [SomeDynInit x])
819 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
820 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
821 , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe
822 , eventEnvIntClears :: !(IORef [Some IntClear])
823 , eventEnvRootClears :: !(IORef [Some RootClear])
824 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
825 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
826 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
829{-# INLINE runEventM #-}
830runEventM :: EventM x a -> IO a
833asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
834asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
836class MonadIO m => Defer a m where
837 getDeferralQueue :: m (IORef [a])
840defer :: Defer a m => a -> m ()
842 q <- getDeferralQueue
843 liftIO $ modifyIORef' q (a:)
845instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
846 {-# INLINE getDeferralQueue #-}
847 getDeferralQueue = asksEventEnv eventEnvAssignments
849instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
850 {-# INLINE getDeferralQueue #-}
851 getDeferralQueue = asksEventEnv eventEnvHoldInits
853instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
854 {-# INLINE getDeferralQueue #-}
855 getDeferralQueue = asksEventEnv eventEnvDynInits
857instance Defer (SomeHoldInit x) (BehaviorM x) where
858 {-# INLINE getDeferralQueue #-}
859 getDeferralQueue = BehaviorM $ asks snd
861instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
862 {-# INLINE getDeferralQueue #-}
863 getDeferralQueue = asksEventEnv eventEnvMergeUpdates
865instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
866 {-# INLINE getDeferralQueue #-}
867 getDeferralQueue = asksEventEnv eventEnvMergeInits
869class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
870 getCurrentHeight :: m Height
871 scheduleMerge :: Height -> EventM x () -> m ()
873instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
874 {-# INLINE getCurrentHeight #-}
875 getCurrentHeight = do
876 heightRef <- asksEventEnv eventEnvCurrentHeight
877 liftIO $ readIORef heightRef
878 {-# INLINE scheduleMerge #-}
879 scheduleMerge height subscribed = do
880 delayedRef <- asksEventEnv eventEnvDelayedMerges
881 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
883class HasSpiderTimeline x where
884 -- | Retrieve the current SpiderTimelineEnv
885 spiderTimeline :: SpiderTimelineEnv x
887instance HasSpiderTimeline Global where
888 spiderTimeline = globalSpiderTimelineEnv
890putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
891putCurrentHeight h = do
892 heightRef <- asksEventEnv eventEnvCurrentHeight
893 liftIO $ writeIORef heightRef $! h
895instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
896 {-# INLINE getDeferralQueue #-}
897 getDeferralQueue = asksEventEnv eventEnvClears
899{-# INLINE scheduleClear #-}
900scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
901scheduleClear r = defer $ Some $ Clear r
903instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
904 {-# INLINE getDeferralQueue #-}
905 getDeferralQueue = asksEventEnv eventEnvIntClears
907{-# INLINE scheduleIntClear #-}
908scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
909scheduleIntClear r = defer $ Some $ IntClear r
911instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
912 {-# INLINE getDeferralQueue #-}
913 getDeferralQueue = asksEventEnv eventEnvRootClears
915{-# INLINE scheduleRootClear #-}
916scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
917scheduleRootClear r = defer $ Some $ RootClear r
919instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
920 {-# INLINE getDeferralQueue #-}
921 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
923-- Note: hold cannot examine its event until after the phase is over
924{-# INLINE [1] hold #-}
925hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
927 valRef <- liftIO $ newIORef v0
928 invsRef <- liftIO $ newIORef []
929 parentRef <- liftIO $ newIORef Nothing
931 nodeId <- liftIO newNodeId
935 , holdInvalidators = invsRef
937 , holdParent = parentRef
939 , holdNodeId = nodeId
942 defer $ SomeHoldInit h
945{-# INLINE getHoldEventSubscription #-}
946getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
947getHoldEventSubscription h = do
948 ep <- liftIO $ readIORef $ holdParent h
950 Just subd -> return subd
953 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
954 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
955 liftIO $ writeIORef subscriptionRef $! subscription
959 old <- liftIO $ readIORef $ holdValue h
963 -- Need to evaluate these so that we don't retain the Hold itself
964 v <- liftIO $ evaluate $ holdValue h
965 i <- liftIO $ evaluate $ holdInvalidators h
966 defer $ SomeAssignment v i new
967 liftIO $ writeIORef (holdParent h) $ Just subscription
970type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
972-- BehaviorM can sample behaviors
973newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
974 deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
976instance Monad (BehaviorM x) where
978 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
980 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
981 {-# INLINE return #-}
982 return x = BehaviorM $ return x
983#if !MIN_VERSION_base(4,13,0)
985 fail s = BehaviorM $ fail s
988data BehaviorSubscribed x a
989 = forall p. BehaviorSubscribedHold (Hold x p)
990 | BehaviorSubscribedPull (PullSubscribed x a)
992newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))
994--type role PullSubscribed representational
995data PullSubscribed x a
996 = PullSubscribed { pullSubscribedValue :: !a
997 , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
998 , pullSubscribedOwnInvalidator :: !(Invalidator x)
999 , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
1002--type role Pull representational
1004 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
1005 , pullCompute :: !(BehaviorM x a)
1012 = forall a. InvalidatorPull (Pull x a)
1013 | forall a. InvalidatorSwitch (SwitchSubscribed x a)
1015data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1016 { rootSubscribedKey :: !(k a)
1017 , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
1018 , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1019 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
1020 , rootSubscribedUninit :: IO ()
1021 , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
1023 , rootSubscribedNodeId :: Int
1028 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1029 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1030 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1033data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1035data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1037data SomeMergeUpdate x = SomeMergeUpdate
1038 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1039 , _someMergeUpdate_invalidateHeight :: !(IO ())
1040 , _someMergeUpdate_recalculateHeight :: !(IO ())
1043newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1045-- EventM can do everything BehaviorM can, plus create holds
1046newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1048newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1050data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1051 { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1052 , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1055data HeightBag = HeightBag
1056 { _heightBag_size :: {-# UNPACK #-} !Int
1057 , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1059 deriving (Show, Read, Eq, Ord)
1061heightBagEmpty :: HeightBag
1062heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1064heightBagSize :: HeightBag -> Int
1065heightBagSize = _heightBag_size
1067heightBagFromList :: [Height] -> HeightBag
1068heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1070heightBagAdd :: Height -> HeightBag -> HeightBag
1071heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1072 IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1074heightBagRemove :: Height -> HeightBag -> HeightBag
1075heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1076 Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1077 Just old -> HeightBag (pred s) $ case old of
1078 0 -> IntMap.delete h c
1079 _ -> IntMap.insert h (pred old) c
1081heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag
1082heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
1083 removed old = HeightBag (pred s) $ case old of
1084 0 -> IntMap.delete h c
1085 _ -> IntMap.insert h (pred old) c
1088heightBagMax :: HeightBag -> Height
1089heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1090 Just ((h, _), _) -> Height h
1091 Nothing -> zeroHeight
1093heightBagVerify :: HeightBag -> HeightBag
1095heightBagVerify b@(HeightBag s c) = if
1096 | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1097 -> error $ "heightBagVerify: size doesn't match: " <> show b
1098 | unHeight invalidHeight `IntMap.member` c
1099 -> error $ "heightBagVerify: contains invalid height: " <> show b
1105data FanSubscribedChildren x k v a = FanSubscribedChildren
1106 { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1107 , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1108 , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1111data FanSubscribed x k v
1112 = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1113 , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1114 , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1115 , fanSubscribedParent :: !(EventSubscription x)
1117 , fanSubscribedNodeId :: Int
1122 = Fan { fanParent :: !(Event x (DMap k v))
1123 , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1126data SwitchSubscribed x a
1127 = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1128 , switchSubscribedOccurrence :: !(IORef (Maybe a))
1129 , switchSubscribedHeight :: !(IORef Height)
1130 , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1131 , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1132 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1133 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1134 , switchSubscribedParent :: !(Behavior x (Event x a))
1135 , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1136 , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1138 , switchSubscribedNodeId :: Int
1143 = Switch { switchParent :: !(Behavior x (Event x a))
1144 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1147#ifdef USE_TEMPLATE_HASKELL
1148{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1150data CoincidenceSubscribed x a
1151 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1152 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1153 , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1154 , coincidenceSubscribedHeight :: !(IORef Height)
1155 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1156 , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1157 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1158 , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1160 , coincidenceSubscribedNodeId :: Int
1165 = Coincidence { coincidenceParent :: !(Event x (Event x a))
1166 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1169{-# NOINLINE newInvalidatorSwitch #-}
1170newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1171newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1173{-# NOINLINE newInvalidatorPull #-}
1174newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1175newInvalidatorPull p = return $! InvalidatorPull p
1177instance HasSpiderTimeline x => Filterable (Event x) where
1178 mapMaybe f = push $ return . f
1180instance HasSpiderTimeline x => Align (Event x) where
1182#if MIN_VERSION_these(0, 8, 0)
1183instance HasSpiderTimeline x => Semialign (Event x) where
1185 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1186 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1188#ifdef MIN_VERSION_semialign
1189#if MIN_VERSION_semialign(1,1,0)
1190instance HasSpiderTimeline x => Zip (Event x) where
1192 zip x y = mapMaybe justThese $ align x y
1195data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1196 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1197 | HoldDyn !(Hold x p)
1199newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1201newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1202newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1204--TODO: Avoid the duplication between this and R.zipDynWith
1205zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1207 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1208 ec = flip push eab $ \o -> do
1210 This (Identity a) -> do
1211 b <- readBehaviorUntracked $ dynamicCurrent db
1213 That (Identity b) -> do
1214 a <- readBehaviorUntracked $ dynamicCurrent da
1216 These (Identity a) (Identity b) -> return (a, b)
1217 return $ Just $ Identity $ f a b
1218 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1220buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1221buildDynamic readV0 v' = do
1222 result <- liftIO $ newIORef $ BuildDyn (readV0, v')
1224 defer $ SomeDynInit d
1227unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1228unsafeBuildDynamic readV0 v' =
1229 Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1231-- ResultM can read behaviors and events
1232type ResultM = EventM
1234instance HasSpiderTimeline x => Functor (Event x) where
1235 fmap f = push $ return . Just . f
1237instance Functor (Behavior x) where
1238 fmap f = pull . fmap f . readBehaviorTracked
1241push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1242push f e = cacheEvent (pushCheap f e)
1244{-# INLINABLE pull #-}
1245pull :: BehaviorM x a -> Behavior x a
1246pull a = unsafePerformIO $ do
1247 ref <- newIORef Nothing
1251 pure $ behaviorPull $ Pull
1259{-# INLINABLE switch #-}
1260switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1261switch a = unsafePerformIO $ do
1262 ref <- newIORef Nothing
1263 pure $ eventSwitch $ Switch
1265 , switchSubscribed = ref
1268coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1269coincidence a = unsafePerformIO $ do
1270 ref <- newIORef Nothing
1271 pure $ eventCoincidence $ Coincidence
1272 { coincidenceParent = a
1273 , coincidenceSubscribed = ref
1276-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1277run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1279 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1280 let t = spiderTimeline :: SpiderTimelineEnv x
1281 result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1282 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1283 occBefore <- liftIO $ do
1284 occBefore <- readIORef occRef
1285 writeIORef occRef $! DMap.insert k a occBefore
1287 if DMap.null occBefore
1288 then do scheduleRootClear occRef
1291 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1292 propagate a subscribersRef
1293 delayedRef <- asksEventEnv eventEnvDelayedMerges
1295 delayed <- liftIO $ readIORef delayedRef
1296 case IntMap.minViewWithKey delayed of
1297 Nothing -> return ()
1298 Just ((currentHeight, cur), future) -> do
1299 tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1300 putCurrentHeight $ Height currentHeight
1301 liftIO $ writeIORef delayedRef $! future
1305 putCurrentHeight maxBound
1307 tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1310scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1311scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1312 height <- liftIO $ readIORef heightRef
1313 currentHeight <- getCurrentHeight
1314 case height `compare` currentHeight of
1315 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1316 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1319newtype Clear a = Clear (IORef (Maybe a))
1321newtype IntClear a = IntClear (IORef (IntMap a))
1323newtype RootClear k = RootClear (IORef (DMap k Identity))
1325data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1327debugFinalize :: Bool
1328debugFinalize = False
1330mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1331mkWeakPtrWithDebug x debugNote = do
1335 then Just $ debugStrLn $ "finalizing: " ++ debugNote
1338type WeakList a = [Weak a]
1340type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1347debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1348debugSubscriber description = return . debugSubscriber' description
1350debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a
1351debugSubscriber' description subscribed = Subscriber
1353 subscriberPropagate = \m -> do
1354 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1355 subscriberPropagate subscribed m
1356 , subscriberInvalidateHeight = \old -> do
1357 traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1358 subscriberInvalidateHeight subscribed old
1359 traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
1360 , subscriberRecalculateHeight = \new -> do
1361 traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1362 subscriberRecalculateHeight subscribed new
1363 traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
1367{-# INLINE withIncreasedDepth #-}
1368withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1369withIncreasedDepth _ a = do
1370 liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ
1372 liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
1375{-# INLINE tracePropagate #-}
1376tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1377tracePropagate p = when debugPropagate . trace p
1379{-# INLINE traceInvalidate #-}
1380traceInvalidate :: String -> IO ()
1381traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1383{-# INLINE traceInvalidateHeight #-}
1384traceInvalidateHeight :: String -> IO ()
1385traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1388trace :: (CanTrace x m) => proxy x -> String -> m ()
1389trace p message = traceM p $ return message
1391{-# INLINE traceM #-}
1392traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1393traceM _ getMessage = do
1394 message <- getMessage
1395 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1396 liftIO $ debugStrLn $ replicate d ' ' <> message
1400{-# INLINE withIncreasedDepth #-}
1401withIncreasedDepth :: proxy x -> m a -> m a
1402withIncreasedDepth _ = id
1404{-# INLINE tracePropagate #-}
1405tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1406tracePropagate _ _ = return ()
1408{-# INLINE traceInvalidate #-}
1409traceInvalidate :: String -> IO ()
1410traceInvalidate _ = return ()
1412{-# INLINE traceInvalidateHeight #-}
1413traceInvalidateHeight :: String -> IO ()
1414traceInvalidateHeight _ = return ()
1416{-# INLINE debugSubscriber #-}
1417debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1418debugSubscriber _ = return
1420{-# INLINE debugSubscriber' #-}
1421debugSubscriber' :: String -> Subscriber x a -> Subscriber x a
1422debugSubscriber' _ = id
1427trace :: (CanTrace x m) => proxy x -> String -> m ()
1428trace _ _ = return ()
1430{-# INLINE traceM #-}
1431traceM :: (CanTrace x m) => proxy x -> m String -> m ()
1432traceM _ _ = return ()
1436whoCreatedIORef :: IORef a -> IO [String]
1437whoCreatedIORef (IORef a) = whoCreated $! a
1439groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1442 (x :| xs) : t -> case groupByHead t of
1443 [] -> [(x, xs :| [])]
1445 | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1446 | otherwise -> (x, xs :| []) : l
1448listsToForest :: Eq a => [[a]] -> Forest a
1449listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)
1450 where buildForest (a, lists') = Node a $ listsToForest $ toList lists'
1452showStacks :: [[String]] -> String
1453showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1455filterStack :: String -> [String] -> [String]
1456#ifdef DEBUG_HIDE_INTERNALS
1457filterStack prefix = filter (not . (prefix `isPrefixOf`))
1459filterStack prefix = id
1464data EventLoopException = EventLoopException [[String]]
1465instance Exception EventLoopException
1467instance Show EventLoopException where
1468 show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1469 then "no location information, compile with profiling enabled for stack tree"
1470 else showStacks stacks
1474data EventLoopException = EventLoopException
1475instance Exception EventLoopException
1477instance Show EventLoopException where
1478 show EventLoopException = "causality loop detected: \n" <>
1479 "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"
1484{-# INLINE propagateSubscriberHold #-}
1485propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1486propagateSubscriberHold h a = do
1487 {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1488 invalidators <- liftIO $ readIORef $ holdInvalidators h
1489 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1491 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1492 case {-# SCC "apply" #-} apply a v of
1493 Nothing -> return ()
1495 {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1496 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1497 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1498 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1499 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1501data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1503runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1504runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1506askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1510 Nothing -> return Nothing
1511 Just (!wi, _) -> return $ Just wi
1513askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1517 Nothing -> return Nothing
1518 Just (_, !p) -> return $ Just p
1520askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1521askBehaviorHoldInits = do
1525{-# INLINE getDynHold #-}
1526getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1528 mh <- liftIO $ readIORef $ unDyn d
1530 HoldDyn h -> return h
1531 UnsafeDyn (readV0, v') -> do
1532 holdInits <- getDeferralQueue
1533 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1535 BuildDyn (readV0, v') -> do
1536 v0 <- liftIO $ runEventM readV0
1541 liftIO $ writeIORef (unDyn d) $ HoldDyn h
1545-- Always refers to 0
1546{-# NOINLINE zeroRef #-}
1547zeroRef :: IORef Height
1548zeroRef = unsafePerformIO $ newIORef zeroHeight
1550getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1551getRootSubscribed k r sub = do
1552 mSubscribed <- readIORef $ rootSubscribed r
1553 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1554 case DMap.lookup k mSubscribed of
1555 Just subscribed -> {-# SCC "hitRoot" #-} do
1556 sln <- subscribeRootSubscribed subscribed sub
1558 return (sln, subscribed, occ)
1559 Nothing -> {-# SCC "missRoot" #-} do
1560 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1561 let !cached = rootSubscribed r
1562 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1563 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1565 tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1567 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1568 writeIORef uninitRef $! uninit
1572 let !subscribed = RootSubscribed
1573 { rootSubscribedKey = k
1574 , rootSubscribedCachedSubscribed = cached
1575 , rootSubscribedOccurrence = getOcc
1576 , rootSubscribedSubscribers = subs
1577 , rootSubscribedUninit = uninit
1578 , rootSubscribedWeakSelf = weakSelf
1580 , rootSubscribedNodeId = nid
1583 -- If we die at the same moment that all our children die, they will
1584 -- try to clean us up but will fail because their Weak reference to us
1585 -- will also be dead. So, if we are dying, check if there are any
1586 -- children; since children don't bother cleaning themselves up if
1587 -- their parents are already dead, I don't think there's a race
1588 -- condition here. However, if there are any children, then we can
1589 -- infer that we need to clean ourselves up, so we do.
1591 cs <- readIORef $ _weakBag_children subs
1592 when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1593 writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1594 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1596 return (sln, subscribed, occ)
1598#ifdef USE_TEMPLATE_HASKELL
1599{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1601cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1602cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1603 rootSubscribedUninit self
1604 modifyIORef' cached $ DMap.delete k
1606{-# INLINE subscribeRootSubscribed #-}
1607subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1608subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1610newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1612data FanInt x a = FanInt
1613 { _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
1614 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1615 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1617 , _fanInt_nodeId :: {-# UNPACK #-} !Int
1621newFanInt :: IO (FanInt x a)
1623 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
1624 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1625 occRef <- newIORef $ error "fanInt: no occurrence"
1630 { _fanInt_subscribers = subscribers
1631 , _fanInt_subscriptionRef = subscriptionRef
1632 , _fanInt_occRef = occRef
1634 , _fanInt_nodeId = nodeId
1638fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1639fanInt p = unsafePerformIO $ do
1641 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1642 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1643 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1644 let desc = "fanInt" <> showNodeId self <> ", k = " <> show k
1645 (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber
1646 { subscriberPropagate = \m -> do
1647 liftIO $ writeIORef (_fanInt_occRef self) m
1648 scheduleIntClear $ _fanInt_occRef self
1649 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1650 FastWeakBag.traverse_ b $ \s ->
1651 subscriberPropagate s v
1652 , subscriberInvalidateHeight = \old ->
1653 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1654 FastWeakBag.traverse_ b $ \s ->
1655 subscriberInvalidateHeight s old
1656 , subscriberRecalculateHeight = \new ->
1657 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1658 FastWeakBag.traverse_ b $ \s ->
1659 subscriberRecalculateHeight s new
1662 writeIORef (_fanInt_subscriptionRef self) subscription
1663 writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1664 scheduleIntClear $ _fanInt_occRef self
1666 b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1668 b <- FastWeakBag.empty
1669 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1672 ticket <- liftIO $ FastWeakBag.insert sub b
1673 currentOcc <- readIORef (_fanInt_occRef self)
1675 subscribed <- fanIntSubscribed ticket self
1676 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1678fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1679fanIntSubscribed ticket self = do
1680 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1681 return $ EventSubscribed
1682 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1683 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1685 , eventSubscribedGetParents = return [subscribedParent]
1686 , eventSubscribedHasOwnHeightRef = False
1687 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1692{-# INLINABLE getFanSubscribed #-}
1693getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1694getFanSubscribed k f sub = do
1695 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1697 Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1698 sln <- subscribeFanSubscribed k subscribed sub
1699 occ <- readIORef $ fanSubscribedOccurrence subscribed
1700 return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1701 Nothing -> {-# SCC "missFan" #-} do
1702 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1703 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1704 s <- liftIO $ newSubscriberFan subscribedUnsafe
1705 (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1706 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1707 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1708 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1709 occRef <- liftIO $ newIORef parentOcc
1710 when (isJust parentOcc) $ scheduleClear occRef
1712 nid <- liftIO newNodeId
1714 let subscribed = FanSubscribed
1715 { fanSubscribedCachedSubscribed = fanSubscribed f
1716 , fanSubscribedOccurrence = occRef
1717 , fanSubscribedParent = subscription
1718 , fanSubscribedSubscribers = subscribersRef
1720 , fanSubscribedNodeId = nid
1723 let !self = (k, subscribed)
1724 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1725 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1726 liftIO $ writeIORef subscribedRef $! subscribed
1727 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1728 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1730cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1731cleanupFanSubscribed (k, subscribed) = do
1732 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1733 let reducedSubscribers = DMap.delete k subscribers
1734 if DMap.null reducedSubscribers
1736 unsubscribe $ fanSubscribedParent subscribed
1737 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1738 writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1739 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1741{-# INLINE subscribeFanSubscribed #-}
1742subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1743subscribeFanSubscribed k subscribed sub = do
1744 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1745 case DMap.lookup k subscribers of
1746 Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1747 let !self = (k, subscribed)
1748 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1749 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1750 writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers
1752 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1754{-# INLINABLE getSwitchSubscribed #-}
1755getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1756getSwitchSubscribed s sub = do
1757 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1759 Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1760 sln <- subscribeSwitchSubscribed subscribed sub
1761 occ <- readIORef $ switchSubscribedOccurrence subscribed
1762 return (sln, subscribed, occ)
1763 Nothing -> {-# SCC "missSwitch" #-} do
1764 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1765 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1766 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1767 mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1768 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1769 wiRef <- liftIO $ newIORef wi
1770 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1771 holdInits <- getDeferralQueue
1772 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1773 (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1774 heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1775 subscriptionRef <- liftIO $ newIORef subscription
1776 occRef <- liftIO $ newIORef parentOcc
1777 when (isJust parentOcc) $ scheduleClear occRef
1778 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1779 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1781 nid <- liftIO newNodeId
1783 let !subscribed = SwitchSubscribed
1784 { switchSubscribedCachedSubscribed = switchSubscribed s
1785 , switchSubscribedOccurrence = occRef
1786 , switchSubscribedHeight = heightRef
1787 , switchSubscribedSubscribers = subs
1788 , switchSubscribedOwnInvalidator = i
1789 , switchSubscribedOwnWeakInvalidator = wiRef
1790 , switchSubscribedBehaviorParents = parentsRef
1791 , switchSubscribedParent = switchParent s
1792 , switchSubscribedCurrentParent = subscriptionRef
1793 , switchSubscribedWeakSelf = weakSelf
1795 , switchSubscribedNodeId = nid
1798 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1799 liftIO $ writeIORef subscribedRef $! subscribed
1800 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1801 return (slnForSub, subscribed, parentOcc)
1803cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1804cleanupSwitchSubscribed subscribed = do
1805 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1806 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1807 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1809{-# INLINE subscribeSwitchSubscribed #-}
1810subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1811subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1813{-# INLINABLE getCoincidenceSubscribed #-}
1814getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1815getCoincidenceSubscribed c sub = do
1816 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1818 Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1819 sln <- subscribeCoincidenceSubscribed subscribed sub
1820 occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1821 return (sln, subscribed, occ)
1822 Nothing -> {-# SCC "missCoincidence" #-} do
1823 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1824 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1825 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1826 (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1827 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1828 (occ, height, mInnerSubd) <- case outerOcc of
1829 Nothing -> return (Nothing, outerHeight, Nothing)
1831 (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1832 return (occ, height, Just innerSubd)
1833 occRef <- liftIO $ newIORef occ
1834 when (isJust occ) $ scheduleClear occRef
1835 heightRef <- liftIO $ newIORef height
1836 innerSubdRef <- liftIO $ newIORef mInnerSubd
1837 scheduleClear innerSubdRef
1838 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1839 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1841 nid <- liftIO newNodeId
1843 let subscribed = CoincidenceSubscribed
1844 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1845 , coincidenceSubscribedOccurrence = occRef
1846 , coincidenceSubscribedHeight = heightRef
1847 , coincidenceSubscribedSubscribers = subs
1848 , coincidenceSubscribedOuter = subOuter
1849 , coincidenceSubscribedOuterParent = outerSubscription
1850 , coincidenceSubscribedInnerParent = innerSubdRef
1851 , coincidenceSubscribedWeakSelf = weakSelf
1853 , coincidenceSubscribedNodeId = nid
1856 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1857 liftIO $ writeIORef subscribedRef $! subscribed
1858 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1859 return (slnForSub, subscribed, occ)
1861cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1862cleanupCoincidenceSubscribed subscribed = do
1863 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1864 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1866{-# INLINE subscribeCoincidenceSubscribed #-}
1867subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1868subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1870{-# INLINE mergeG #-}
1871mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1872 => (forall a. q a -> Event x (v a))
1873 -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1874mergeG nt d = cacheEvent (mergeCheap nt d)
1876{-# INLINE mergeWithMove #-}
1877mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1878 => (forall a. q a -> Event x (v a))
1879 -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1880mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1882{-# INLINE [1] mergeCheap #-}
1884 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1885 => (forall a. q a -> Event x (v a))
1886 -> DynamicS x (PatchDMap k q)
1887 -> Event x (DMap k v)
1888mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy
1890 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1891 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1892 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1893 (mOldSubd, newPs) <- case me of
1894 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1896 let s = subscriber $ return k
1897 subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1898 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1899 let newParent = MergeSubscribedParent subscription
1900 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1901 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1902 forM_ mOldSubd $ \oldSubd -> do
1903 oldHeight <- liftIO $ getEventSubscribedHeight $
1904 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1906 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1907 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1908 foldM f ([], oldParents) $ DMap.toList p
1910 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1911 getInitialSubscribers initialParents subscriber = do
1912 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1913 let s = subscriber $ return k
1914 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1915 height <- liftIO $ getEventSubscribedHeight parentSubd
1916 return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1917 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1918 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1919 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1922 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1923 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1925{-# INLINE [1] mergeCheapWithMove #-}
1926mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1927 => (forall a. q a -> Event x (v a))
1928 -> DynamicS x (PatchDMapWithMove k q)
1929 -> Event x (DMap k v)
1930mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy
1932 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1933 updateMe subscriber heightBagRef oldParents p = do
1934 -- Prepare new parents for insertion
1935 let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1936 subscribeParent k e = do
1937 keyRef <- liftIO $ newIORef k
1938 let s = subscriber $ liftIO $ readIORef keyRef
1939 subscription@(EventSubscription _ subd) <- subscribe e s
1941 newParentHeight <- getEventSubscribedHeight subd
1942 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1943 return $ MergeSubscribedParentWithMove subscription keyRef
1944 p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1945 -- Collect old parents for deletion and update the keys of moved parents
1946 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1947 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1949 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1950 _mergeSubscribedParentWithMove_subscription parent
1952 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1953 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1955 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1957 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1958 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1960 return (toDelete, applyAlways p' oldParents)
1961 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1962 getInitialSubscribers initialParents subscriber = do
1963 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1964 keyRef <- liftIO $ newIORef k
1965 let s = subscriber $ liftIO $ readIORef keyRef
1966 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1967 height <- liftIO $ getEventSubscribedHeight parentSubd
1968 return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1969 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1970 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1971 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1974 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1975 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1977type MergeUpdateFunc k v x p s
1978 = (forall a. EventM x (k a) -> Subscriber x (v a))
1982 -> EventM x ([EventSubscription x], DMap k s)
1984type MergeGetSubscription x s = forall a. s a -> EventSubscription x
1986type MergeInitFunc k v q x s
1988 -> (forall a. EventM x (k a) -> Subscriber x (v a))
1989 -> EventM x (DMap k v, [Height], DMap k s)
1991type MergeDestroyFunc k s
1995data Merge x k v s = Merge
1996 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1997 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1998 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1999 , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
2000 , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
2003invalidateMergeHeight :: Merge x k v s -> IO ()
2004invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
2006invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
2007invalidateMergeHeight' heightRef sub = do
2008 oldHeight <- readIORef heightRef
2009 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
2010 when (oldHeight /= invalidHeight) $ do
2011 writeIORef heightRef $! invalidHeight
2012 subscriberInvalidateHeight sub oldHeight
2014revalidateMergeHeight :: Merge x k v s -> IO ()
2015revalidateMergeHeight m = do
2016 currentHeight <- readIORef $ _merge_heightRef m
2018 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
2019 when (currentHeight == invalidHeight) $ do
2020 heights <- readIORef $ _merge_heightBagRef m
2021 parents <- readIORef $ _merge_parentsRef m
2022 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
2023 case heightBagSize heights `compare` DMap.size parents of
2026 let height = succHeight $ heightBagMax heights
2027 traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2028 writeIORef (_merge_heightRef m) $! height
2029 subscriberRecalculateHeight (_merge_sub m) height
2030 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
2032scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
2033scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
2034 vals <- liftIO $ readIORef $ _merge_accumRef m
2035 -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
2036 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
2037 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
2038 --TODO: Assert that m is not empty
2039 subscriberPropagate (_merge_sub m) vals
2041checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()
2042checkCycle subscribed = liftIO $ do
2043 height <- readIORef (eventSubscribedHeightRef subscribed)
2045 -- currentHeight <- getCurrentHeight
2046 -- when (height <= currentHeight) $ if height /= invalidHeight
2048 -- myStack <- liftIO $ whoCreatedIORef undefined --TODO
2049 -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
2051 when (height == invalidHeight) $
2054 nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
2055 stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
2056 throwIO (EventLoopException stacks)
2058 throwIO EventLoopException
2062mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
2063mergeSubscriber subscribed m getKey = Subscriber
2064 { subscriberPropagate = \a -> do
2065 oldM <- liftIO $ readIORef $ _merge_accumRef m
2067 let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
2068 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
2069 liftIO $ writeIORef (_merge_accumRef m) $! newM
2070 when (DMap.null oldM) $ do -- Only schedule the firing once
2071 height <- liftIO $ readIORef $ _merge_heightRef m
2072 checkCycle subscribed
2074 scheduleMergeSelf m height
2075 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
2076 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
2077 invalidateMergeHeight m
2078 , subscriberRecalculateHeight = \new -> do
2079 modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
2080 revalidateMergeHeight m
2083--TODO: Be able to run as much of this as possible promptly
2084updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
2085updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
2087 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
2088 (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
2089 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
2090 return subscriptionsToKill
2092{-# INLINE mergeGCheap' #-}
2093mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
2094 => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
2095mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
2096 initialParents <- readBehaviorUntracked $ dynamicCurrent d
2097 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
2098 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
2099 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
2100 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
2101 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2103 let subscribed = EventSubscribed
2104 { eventSubscribedHeightRef = heightRef
2105 , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2107 , eventSubscribedGetParents = do
2108 let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)
2109 fmap getParent' . DMap.toList <$> readIORef parentsRef
2110 , eventSubscribedHasOwnHeightRef = False
2111 , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2116 { _merge_parentsRef = parentsRef
2117 , _merge_heightBagRef = heightBagRef
2118 , _merge_heightRef = heightRef
2120 , _merge_accumRef = accumRef
2122 (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
2123 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
2124 myHeight = if invalidHeight `elem` heights
2126 else succHeight $ heightBagMax myHeightBag
2127 currentHeight <- getCurrentHeight
2128 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
2129 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
2131 unless (DMap.null accum) $ scheduleMergeSelf m myHeight
2132 liftIO $ writeIORef accumRef $! accum
2133 liftIO $ writeIORef heightRef $! myHeight
2134 liftIO $ writeIORef heightBagRef $! myHeightBag
2135 liftIO $ writeIORef parentsRef $! initialParentState
2136 defer $ SomeMergeInit $ do
2137 let changeSubscriber = Subscriber
2138 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2139 tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
2140 defer $ updateMerge subscribed m updateFunc a
2141 , subscriberInvalidateHeight = \_ -> return ()
2142 , subscriberRecalculateHeight = \_ -> return ()
2144 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2145 forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
2146 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2147 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2148 -- its subscription.
2149 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2150 let unsubscribeAll = destroy =<< readIORef parentsRef
2152 return (EventSubscription unsubscribeAll subscribed, occ)
2155mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2156mergeInt = cacheEvent . mergeIntCheap
2158{-# INLINABLE mergeIntCheap #-}
2159mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2160mergeIntCheap d = Event $ \sub -> do
2161 initialParents <- readBehaviorUntracked $ dynamicCurrent d
2162 accum <- liftIO $ FastMutableIntMap.newEmpty
2163 heightRef <- liftIO $ newIORef zeroHeight
2164 heightBagRef <- liftIO $ newIORef heightBagEmpty
2165 parents <- liftIO $ FastMutableIntMap.newEmpty
2166 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2167 let subscribed = EventSubscribed
2168 { eventSubscribedHeightRef = heightRef
2169 , eventSubscribedRetained = toAny (parents, changeSubdRef)
2171 , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2172 , eventSubscribedHasOwnHeightRef = False
2173 , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2176 let scheduleSelf = do
2177 height <- liftIO $ readIORef $ heightRef
2178 scheduleMerge' height heightRef $ do
2179 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2180 subscriberPropagate sub vals
2181 invalidateMyHeight = invalidateMergeHeight' heightRef sub
2182 recalculateMyHeight = do
2183 currentHeight <- readIORef heightRef
2184 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?
2185 heights <- readIORef heightBagRef
2186 numParents <- FastMutableIntMap.size parents
2187 case heightBagSize heights `compare` numParents of
2190 let height = succHeight $ heightBagMax heights
2191 traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2192 writeIORef heightRef $! height
2193 subscriberRecalculateHeight sub height
2194 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2195 mySubscriber k = Subscriber
2196 { subscriberPropagate = \a -> do
2197 checkCycle subscribed
2199 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2200 liftIO $ FastMutableIntMap.insert accum k a
2201 when wasEmpty scheduleSelf
2202 , subscriberInvalidateHeight = \old -> do
2203 modifyIORef' heightBagRef $ heightBagRemove old
2205 , subscriberRecalculateHeight = \new -> do
2206 modifyIORef' heightBagRef $ heightBagAdd new
2209 forM_ (IntMap.toList initialParents) $ \(k, p) -> do
2210 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
2212 forM_ parentOcc $ FastMutableIntMap.insert accum k
2213 FastMutableIntMap.insert parents k subscription
2214 height <- getEventSubscribedHeight parentSubd
2215 if height == invalidHeight
2216 then writeIORef heightRef invalidHeight
2218 modifyIORef' heightBagRef $ heightBagAdd height
2219 modifyIORef' heightRef $ \oldHeight ->
2220 if oldHeight == invalidHeight
2222 else max (succHeight height) oldHeight
2223 myHeight <- liftIO $ readIORef heightRef
2224 currentHeight <- getCurrentHeight
2225 isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2226 occ <- if currentHeight >= myHeight -- If we should have fired by now
2229 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2230 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2232 defer $ SomeMergeInit $ do
2233 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2236 let f k newParent = do
2237 subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
2238 newParentHeight <- liftIO $ getEventSubscribedHeight subd
2239 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
2241 newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
2242 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2243 liftIO $ for_ oldParents $ \oldParent -> do
2244 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2246 print ("updateMe", oldParentHeight)
2247 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2248 return $ IntMap.elems oldParents
2249 let changeSubscriber = Subscriber
2250 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2251 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2253 , subscriberInvalidateHeight = \_ -> return ()
2254 , subscriberRecalculateHeight = \_ -> return ()
2256 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2257 forM_ change $ \c -> defer $ updateMe c
2258 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2259 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2260 -- its subscription.
2261 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2262 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2265 return (EventSubscription unsubscribeAll subscribed, occ)
2267newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2268newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2270fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2271fanG e = unsafePerformIO $ do
2272 ref <- newIORef Nothing
2275 , fanSubscribed = ref
2277 pure $ EventSelectorG $ \k -> eventFan k f
2279runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2280runHoldInits holdInitRef dynInitRef mergeInitRef = do
2281 holdInits <- liftIO $ readIORef holdInitRef
2282 dynInits <- liftIO $ readIORef dynInitRef
2283 mergeInits <- liftIO $ readIORef mergeInitRef
2284 unless (null holdInits && null dynInits && null mergeInits) $ do
2285 liftIO $ writeIORef holdInitRef []
2286 liftIO $ writeIORef dynInitRef []
2287 liftIO $ writeIORef mergeInitRef []
2288 mapM_ initHold holdInits
2289 mapM_ initDyn dynInits
2290 mapM_ unSomeMergeInit mergeInits
2291 runHoldInits holdInitRef dynInitRef mergeInitRef
2293initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2294initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2296initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2297initDyn (SomeDynInit d) = void $ getDynHold d
2299newEventEnv :: IO (EventEnv x)
2301 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2302 holdInitRef <- newIORef []
2303 dynInitRef <- newIORef []
2304 mergeUpdateRef <- newIORef []
2305 mergeInitRef <- newIORef []
2306 heightRef <- newIORef zeroHeight
2307 toClearRef <- newIORef []
2308 toClearIntRef <- newIORef []
2309 toClearRootRef <- newIORef []
2310 coincidenceInfosRef <- newIORef []
2311 delayedRef <- newIORef IntMap.empty
2312 return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2314clearEventEnv :: EventEnv x -> IO ()
2315clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2316 writeIORef toAssignRef []
2317 writeIORef holdInitRef []
2318 writeIORef dynInitRef []
2319 writeIORef mergeUpdateRef []
2320 writeIORef mergeInitRef []
2321 writeIORef heightRef zeroHeight
2322 writeIORef toClearRef []
2323 writeIORef toClearIntRef []
2324 writeIORef toClearRootRef []
2325 writeIORef coincidenceInfosRef []
2326 writeIORef delayedRef IntMap.empty
2328-- | Run an event action outside of a frame
2329runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2330runFrame a = SpiderHost $ do
2331 let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2334 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2336 result <- runEventM go
2337 toClear <- readIORef $ eventEnvClears env
2338 forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2339 toClearInt <- readIORef $ eventEnvIntClears env
2340 forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2341 toClearRoot <- readIORef $ eventEnvRootClears env
2342 forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2343 toAssign <- readIORef $ eventEnvAssignments env
2344 toReconnectRef <- newIORef []
2345 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2346 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2348 traceInvalidate $ "Invalidating Hold"
2349 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2350 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2351 writeIORef (eventEnvMergeUpdates env) []
2352 tracePropagate (Proxy::Proxy x) $ "Updating merges"
2353 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2354 tracePropagate (Proxy::Proxy x) $ "Updating merges done"
2355 toReconnect <- readIORef toReconnectRef
2357 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2358 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2359 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2360 traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2362 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2363 wi' <- mkWeakPtrWithDebug i "wi'"
2364 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2365 writeIORef (switchSubscribedBehaviorParents subscribed) []
2366 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2367 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2368 runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
2369 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2370 sub <- newSubscriberSwitch subscribed
2371 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2373 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2374 liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2375 EventRoot _ -> "EventRoot"
2376 EventNever -> "EventNever"
2377 _ -> "something else"
2379 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2380 return oldSubscription
2381 liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2382 liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2383 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2384 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2385 parentHeight <- getEventSubscribedHeight subd'
2386 myHeight <- readIORef $ switchSubscribedHeight subscribed
2387 when (parentHeight /= myHeight) $ do
2388 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2389 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2390 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
2391 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2392 unsubscribe subscription
2393 mapM_ invalidateCoincidenceHeight mcs
2394 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2395 mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2396 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2397 height <- calculateSwitchHeight subscribed
2398 updateSwitchHeight height subscribed
2401newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2403{-# INLINE zeroHeight #-}
2405zeroHeight = Height 0
2407{-# INLINE invalidHeight #-}
2408invalidHeight :: Height
2409invalidHeight = Height (-1000)
2412-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2413{-# INLINE invalidHeightBeingTraversed #-}
2414invalidHeightBeingTraversed :: Height
2415invalidHeightBeingTraversed = Height (-1001)
2418{-# INLINE succHeight #-}
2419succHeight :: Height -> Height
2420succHeight h@(Height a) =
2421 if h == invalidHeight
2423 else Height $ succ a
2425invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2426invalidateCoincidenceHeight subscribed = do
2427 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2428 when (oldHeight /= invalidHeight) $ do
2429 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2430 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2432updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2433updateSwitchHeight new subscribed = do
2434 oldHeight <- readIORef $ switchSubscribedHeight subscribed
2435 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2436 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2437 writeIORef (switchSubscribedHeight subscribed) $! new
2438 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2440recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2441recalculateCoincidenceHeight subscribed = do
2442 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2443 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2444 height <- calculateCoincidenceHeight subscribed
2445 when (height /= invalidHeight) $ do
2446 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2447 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2449calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2450calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2452calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2453calculateCoincidenceHeight subscribed = do
2454 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2455 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2456 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2458data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2460invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2461invalidate toReconnectRef wis = do
2462 forM_ wis $ \wi -> do
2466 traceInvalidate "invalidate Dead"
2467 return () --TODO: Should we clean this up here?
2469 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2471 InvalidatorPull p -> do
2472 traceInvalidate $ "invalidate: Pull" <> showNodeId p
2473 mVal <- readIORef $ pullValue p
2474 forM_ mVal $ \val -> do
2475 writeIORef (pullValue p) Nothing
2476 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2477 InvalidatorSwitch subscribed -> do
2478 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2479 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2480 return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
2482--------------------------------------------------------------------------------
2483-- Reflex integration
2484--------------------------------------------------------------------------------
2486-- | Designates the default, global Spider timeline
2487data SpiderTimeline x
2488type role SpiderTimeline nominal
2490-- | The default, global Spider environment
2491type Spider = SpiderTimeline Global
2493instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
2494 {-# INLINABLE sample #-}
2495 sample (SpiderBehavior b) = readBehaviorUntracked b
2497instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
2498 {-# INLINABLE hold #-}
2499 hold = holdSpiderEventM
2500 {-# INLINABLE holdDyn #-}
2501 holdDyn = holdDynSpiderEventM
2502 {-# INLINABLE holdIncremental #-}
2503 holdIncremental = holdIncrementalSpiderEventM
2504 {-# INLINABLE buildDynamic #-}
2505 buildDynamic = buildDynamicSpiderEventM
2506 {-# INLINABLE headE #-}
2508-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2510instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2511 {-# INLINABLE sample #-}
2512 sample = coerce . readBehaviorTracked . unSpiderBehavior
2514instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2515 {-# INLINABLE sample #-}
2516 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2518instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2519 {-# INLINABLE hold #-}
2520 hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
2521 {-# INLINABLE holdDyn #-}
2522 holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
2523 {-# INLINABLE holdIncremental #-}
2524 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
2525 {-# INLINABLE buildDynamic #-}
2526 buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
2527 {-# INLINABLE headE #-}
2529-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2531instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2532 {-# INLINE return #-}
2534 {-# INLINE (>>=) #-}
2535 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2538#if !MIN_VERSION_base(4,13,0)
2540 fail _ = error "Dynamic does not support 'fail'"
2543{-# INLINABLE newJoinDyn #-}
2544newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2546 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2547 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2548 eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
2549 eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
2550 v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
2551 in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2553instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2554 fmap = mapDynamicSpider
2555 x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2557mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b
2558mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2559{-# INLINE [1] mapDynamicSpider #-}
2561instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2562 pure = SpiderDynamic . dynamicConst
2563#if MIN_VERSION_base(4,10,0)
2564 liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
2566 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
2567 a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]
2568 (<*) = flip (*>) -- There are no effects, so order doesn't matter
2570holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
2571holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2573holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2574holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2576holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
2577holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2579buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2580buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2582instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
2583 {-# INLINABLE hold #-}
2584 hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
2585 {-# INLINABLE holdDyn #-}
2586 holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
2587 {-# INLINABLE holdIncremental #-}
2588 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
2589 {-# INLINABLE buildDynamic #-}
2590 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2591 {-# INLINABLE headE #-}
2592 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2594instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2595 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2597instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2598 {-# INLINABLE hold #-}
2599 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2600 {-# INLINABLE holdDyn #-}
2601 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2602 {-# INLINABLE holdIncremental #-}
2603 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2604 {-# INLINABLE buildDynamic #-}
2605 buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2606 {-# INLINABLE headE #-}
2608-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2610instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2611 {-# INLINABLE sample #-}
2612 sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2614instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2615 {-# INLINABLE sample #-}
2616 sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
2618instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2619 {-# INLINABLE hold #-}
2620 hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
2621 {-# INLINABLE holdDyn #-}
2622 holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
2623 {-# INLINABLE holdIncremental #-}
2624 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
2625 {-# INLINABLE buildDynamic #-}
2626 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2627 {-# INLINABLE headE #-}
2628 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2630--------------------------------------------------------------------------------
2632--------------------------------------------------------------------------------
2634-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
2635{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2636type SpiderEnv = SpiderTimeline
2637instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2638 {-# INLINABLE subscribeEvent #-}
2639 subscribeEvent e = SpiderHostFrame $ do
2640 --TODO: Unsubscribe eventually (manually and/or with weak ref)
2641 val <- liftIO $ newIORef Nothing
2642 subscription <- subscribe (unSpiderEvent e) $ Subscriber
2643 { subscriberPropagate = \a -> do
2644 liftIO $ writeIORef val $ Just a
2646 , subscriberInvalidateHeight = \_ -> return ()
2647 , subscriberRecalculateHeight = \_ -> return ()
2649 return $ SpiderEventHandle
2650 { spiderEventHandleSubscription = subscription
2651 , spiderEventHandleValue = val
2654instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
2655 type EventTrigger (SpiderTimeline x) = RootTrigger x
2656 type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2657 type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2659instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2660 {-# NOINLINE readEvent #-}
2661 readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
2662 result <- readIORef $ spiderEventHandleValue h
2666instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2667 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2668 newFanEventWithTrigger f = SpiderHost $ do
2669 es <- newFanEventWithTriggerIO f
2670 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2672instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2673 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2674 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2675 es <- newFanEventWithTriggerIO f
2676 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2678instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2679 {-# INLINABLE subscribeEvent #-}
2680 subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
2682instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2683 type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
2684 fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
2685 runHostFrame = runFrame . runSpiderHostFrame
2687unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2688unsafeNewSpiderTimelineEnv = do
2692 depthRef <- newIORef 0
2694 return $ STE $ SpiderTimelineEnv
2695 { _spiderTimeline_lock = lock
2696 , _spiderTimeline_eventEnv = env
2698 , _spiderTimeline_depth = depthRef
2702-- | Create a new SpiderTimelineEnv
2703newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2704newSpiderTimeline = withSpiderTimeline (pure . Some)
2706data LocalSpiderTimeline (x :: Type) s
2708instance Reifies s (SpiderTimelineEnv x) =>
2709 HasSpiderTimeline (LocalSpiderTimeline x s) where
2710 spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2714 -> SpiderTimelineEnv x
2715 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2716localSpiderTimeline _ = coerce
2718-- | Pass a new timeline to the given function.
2719withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2720withSpiderTimeline k = do
2721 env <- unsafeNewSpiderTimelineEnv
2722 reify env $ \s -> k $ localSpiderTimeline s env
2724newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2726type ComputeM = EventM
2728newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2730instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2731 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2732 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2733 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2734 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2735 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2736 type PullM (SpiderTimeline x) = SpiderPullM x
2737 type PushM (SpiderTimeline x) = SpiderPushM x
2738 {-# INLINABLE never #-}
2739 never = SpiderEvent eventNever
2740 {-# INLINABLE constant #-}
2741 constant = SpiderBehavior . behaviorConst
2743 push f = SpiderEvent . push (coerce f) . unSpiderEvent
2744 {-# INLINE pushCheap #-}
2745 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2746 {-# INLINABLE pull #-}
2747 pull = SpiderBehavior . pull . coerce
2748 {-# INLINABLE fanG #-}
2749 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2750 {-# INLINABLE mergeG #-}
2752 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2753 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2755 -> R.Event (SpiderTimeline x) (DMap k v)
2756 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2757 {-# INLINABLE switch #-}
2758 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2759 {-# INLINABLE coincidence #-}
2760 coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2761 {-# INLINABLE current #-}
2762 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2763 {-# INLINABLE updated #-}
2764 updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2765 {-# INLINABLE unsafeBuildDynamic #-}
2766 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2767 {-# INLINABLE unsafeBuildIncremental #-}
2768 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2769 {-# INLINABLE mergeIncrementalG #-}
2770 mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2771 {-# INLINABLE mergeIncrementalWithMoveG #-}
2772 mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2773 {-# INLINABLE currentIncremental #-}
2774 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2775 {-# INLINABLE updatedIncremental #-}
2776 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2777 {-# INLINABLE incrementalToDynamic #-}
2778 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2779 c <- readBehaviorUntracked $ dynamicCurrent i
2780 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2781 eventCoercion Coercion = Coercion
2782 behaviorCoercion Coercion = Coercion
2783 dynamicCoercion Coercion = Coercion
2784 incrementalCoercion Coercion Coercion = Coercion
2785 {-# INLINABLE mergeIntIncremental #-}
2786 mergeIntIncremental = SpiderEvent . mergeInt . coerce
2787 {-# INLINABLE fanInt #-}
2788 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2790data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2792data SpiderEventHandle x a = SpiderEventHandle
2793 { spiderEventHandleSubscription :: EventSubscription x
2794 , spiderEventHandleValue :: IORef (Maybe a)
2797instance MonadRef (EventM x) where
2798 type Ref (EventM x) = Ref IO
2799 {-# INLINABLE newRef #-}
2800 {-# INLINABLE readRef #-}
2801 {-# INLINABLE writeRef #-}
2802 newRef = liftIO . newRef
2803 readRef = liftIO . readRef
2804 writeRef r a = liftIO $ writeRef r a
2806instance MonadAtomicRef (EventM x) where
2807 {-# INLINABLE atomicModifyRef #-}
2808 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2810-- | The monad for actions that manipulate a Spider timeline identified by @x@
2811newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2813instance Monad (SpiderHost x) where
2814 {-# INLINABLE (>>=) #-}
2815 SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2816 {-# INLINABLE (>>) #-}
2817 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2818 {-# INLINABLE return #-}
2819 return x = SpiderHost $ return x
2820#if !MIN_VERSION_base(4,13,0)
2821 {-# INLINABLE fail #-}
2822 fail = MonadFail.fail
2825instance MonadFail (SpiderHost x) where
2826 {-# INLINABLE fail #-}
2827 fail s = SpiderHost $ MonadFail.fail s
2829-- | Run an action affecting the global Spider timeline; this will be guarded by
2830-- a mutex for that timeline
2831runSpiderHost :: SpiderHost Global a -> IO a
2832runSpiderHost (SpiderHost a) = a
2834-- | Run an action affecting a given Spider timeline; this will be guarded by a
2835-- mutex for that timeline
2836runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2837runSpiderHostForTimeline (SpiderHost a) _ = a
2839newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2840 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2842instance Monad (SpiderHostFrame x) where
2843 {-# INLINABLE (>>=) #-}
2844 SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2845 {-# INLINABLE (>>) #-}
2846 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2847 {-# INLINABLE return #-}
2848 return x = SpiderHostFrame $ return x
2849#if !MIN_VERSION_base(4,13,0)
2850 {-# INLINABLE fail #-}
2851 fail s = SpiderHostFrame $ fail s
2854instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2855 notReadyUntil _ = pure ()
2858newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2859newEventWithTriggerIO f = do
2860 es <- newFanEventWithTriggerIO $ \Refl -> f
2861 return $ select es Refl
2863newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2864newFanEventWithTriggerIO f = do
2865 occRef <- newIORef DMap.empty
2866 subscribedRef <- newIORef DMap.empty
2868 { rootOccurrence = occRef
2869 , rootSubscribed = subscribedRef
2872 return $ EventSelector $ \k -> eventRoot k r
2874newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2876instance MonadRef (SpiderHost x) where
2877 type Ref (SpiderHost x) = Ref IO
2878 newRef = SpiderHost . newRef
2879 readRef = SpiderHost . readRef
2880 writeRef r = SpiderHost . writeRef r
2882instance MonadAtomicRef (SpiderHost x) where
2883 atomicModifyRef r = SpiderHost . atomicModifyRef r
2885instance MonadRef (SpiderHostFrame x) where
2886 type Ref (SpiderHostFrame x) = Ref IO
2887 newRef = SpiderHostFrame . newRef
2888 readRef = SpiderHostFrame . readRef
2889 writeRef r = SpiderHostFrame . writeRef r
2891instance MonadAtomicRef (SpiderHostFrame x) where
2892 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2894instance PrimMonad (SpiderHostFrame x) where
2895 type PrimState (SpiderHostFrame x) = PrimState IO
2896 primitive = SpiderHostFrame . EventM . primitive
2898instance NotReady (SpiderTimeline x) (SpiderHost x) where
2899 notReadyUntil _ = return ()
2900 notReady = return ()
2902instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2903 notReadyUntil _ = return ()
2904 notReady = return ()
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list