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 MagicHash #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
14{-# LANGUAGE MultiWayIf #-}
15{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE RoleAnnotations #-}
17{-# LANGUAGE ScopedTypeVariables #-}
18{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE UndecidableInstances #-}
21#ifdef USE_REFLEX_OPTIMIZER
22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
24#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
25{-# OPTIONS_GHC -fno-warn-orphans #-}
27-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
28-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
29module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
31import Control.Applicative
32import Control.Concurrent
33import Control.Exception
34import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
35import Control.Monad.Exception
36import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
37import Control.Monad.Primitive
38import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
39import Control.Monad.Ref
42import Data.Dependent.Map (DMap, DSum (..))
43import qualified Data.Dependent.Map as DMap
44import Data.Foldable hiding (concat, elem, sequence_)
46import Data.Functor.Constant
47import Data.Functor.Misc
48import Data.Functor.Product
49import Data.GADT.Compare
50import Data.IntMap.Strict (IntMap)
51import qualified Data.IntMap.Strict as IntMap
53import Data.List hiding (foldl')
55import Data.Monoid ((<>))
58import Data.Traversable
61import GHC.IORef (IORef (..))
64import Reflex.FunctorMaybe
65import System.IO.Unsafe
70import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
71import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
72import qualified Data.List.NonEmpty as NonEmpty
73import Data.Monoid (mempty)
74import Data.Tree (Forest, Tree (..), drawForest)
77import Data.FastWeakBag (FastWeakBag)
78import qualified Data.FastWeakBag as FastWeakBag
79import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
80import qualified Data.WeakBag as WeakBag
81#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
83import Data.Some (Some)
84import qualified Data.Some as Some
85import Data.Type.Coercion
86import qualified Reflex.Class
87import qualified Reflex.Class as R
88import qualified Reflex.Host.Class
91import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
93-- Note: must come last to silence warnings due to AMP on GHC < 7.10
94import Prelude hiding (any, concat, mapM, mapM_, sequence)
96#ifdef DEBUG_TRACE_EVENTS
97import System.IO (stderr)
98import qualified Data.ByteString.Char8 as BS8
101#ifdef DEBUG_TRACE_EVENTS
103withStackOneLine :: (BS8.ByteString -> a) -> a
104withStackOneLine expr = unsafePerformIO $ do
105 stack <- currentCallStack
106 return (expr (BS8.pack (unwords (reverse stack))))
110debugPropagate :: Bool
112debugInvalidateHeight :: Bool
114debugInvalidate :: Bool
122debugInvalidateHeight = False
124debugInvalidate = True
126class HasNodeId a where
127 getNodeId :: a -> Int
129instance HasNodeId (Hold x p a) where
130 getNodeId = holdNodeId
132instance HasNodeId (PushSubscribed x a b) where
133 getNodeId = pushSubscribedNodeId
135instance HasNodeId (SwitchSubscribed x a) where
136 getNodeId = switchSubscribedNodeId
138instance HasNodeId (FanSubscribed x a) where
139 getNodeId = fanSubscribedNodeId
141instance HasNodeId (CoincidenceSubscribed x a) where
142 getNodeId = coincidenceSubscribedNodeId
144instance HasNodeId (RootSubscribed x a) where
145 getNodeId = rootSubscribedNodeId
147instance HasNodeId (Pull x a) where
148 getNodeId = pullNodeId
150{-# INLINE showNodeId #-}
151showNodeId :: HasNodeId a => a -> String
152showNodeId = ("#"<>) . show . getNodeId
154showSubscriberType :: Subscriber x a -> String
155showSubscriberType = \case
156 SubscriberPush _ _ -> "SubscriberPush"
157 SubscriberMerge _ _ -> "SubscriberMerge"
158 SubscriberFan _ -> "SubscriberFan"
159 SubscriberMergeChange _ -> "SubscriberMergeChange"
160 SubscriberHold _ -> "SubscriberHold"
161 SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
162 SubscriberSwitch _ -> "SubscriberSwitch"
163 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
164 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
165 SubscriberHandle -> "SubscriberHandle"
167showEventType :: Event x a -> String
169 EventRoot _ _ -> "EventRoot"
170 EventNever -> "EventNever"
171 EventPush _ -> "EventPush"
172 EventMerge _ -> "EventMerge"
173 EventFan _ _ -> "EventFan"
174 EventSwitch _ -> "EventSwitch"
175 EventCoincidence _ -> "EventCoincidence"
176 EventHold _ -> "EventHold"
177 EventDyn _ -> "EventDyn"
178 EventHoldIdentity _ -> "EventHoldIdentity"
179 EventDynIdentity _ -> "EventDynIdentity"
183debugPropagate = False
185debugInvalidateHeight = False
187debugInvalidate = False
189-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
190{-# INLINE showNodeId #-}
191showNodeId :: a -> String
197{-# NOINLINE nextNodeIdRef #-}
198nextNodeIdRef :: IORef Int
199nextNodeIdRef = unsafePerformIO $ newIORef 1
202newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
204{-# NOINLINE unsafeNodeId #-}
205unsafeNodeId :: a -> Int
206unsafeNodeId a = unsafePerformIO $ do
211--------------------------------------------------------------------------------
213--------------------------------------------------------------------------------
215--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
216-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
217data EventSubscription x = EventSubscription
218 { _eventSubscription_unsubscribe :: !(IO ())
219 , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
222unsubscribe :: EventSubscription x -> IO ()
223unsubscribe (EventSubscription u _) = u
225--------------------------------------------------------------------------------
227--------------------------------------------------------------------------------
229newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
231{-# INLINE subscribeAndRead #-}
232subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
233subscribeAndRead = unEvent
236"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
237"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
238"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
241-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
242-- caching; if the computation function is very cheap, this is (much) more
243-- efficient than 'push'
244{-# NOINLINE pushCheap #-}
245pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
246pushCheap f e = Event $ \sub -> do
247 (subscription, occ) <- subscribeAndRead e $ sub
248 { subscriberPropagate = \a -> do
249 mb <- runComputeM $ f a
250 mapM_ (subscriberPropagate sub) mb
252 occ' <- join <$> mapM (runComputeM . f) occ
253 return (subscription, occ')
255data CacheSubscribed x a
256 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
257 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
258 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
261-- | Construct an 'Event' whose value is guaranteed not to be recomputed
264--TODO: Try a caching strategy where we subscribe directly to the parent when
265--there's only one subscriber, and then build our own FastWeakBag only when a second
267{-# NOINLINE cacheEvent #-}
268cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
270#ifdef DEBUG_TRACE_EVENTS
271 withStackOneLine $ \callSite -> Event $
275 let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
276 !mSubscribedRef = unsafeNewIORef e emptyFastWeak
277 in \sub -> {-# SCC "cacheEvent" #-} do
278#ifdef DEBUG_TRACE_EVENTS
279 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
281 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
282 Just subscribedTicket -> return subscribedTicket
284 subscribers <- liftIO FastWeakBag.empty
285 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
286 (parentSub, occ) <- subscribeAndRead e $ Subscriber
287 { subscriberPropagate = \a -> do
288 liftIO $ writeIORef occRef $ Just a
290 propagateFast a subscribers
291 , subscriberInvalidateHeight = \old -> do
292 FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
293 , subscriberRecalculateHeight = \new -> do
294 FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
296 when (isJust occ) $ do
297 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
299 let !subscribed = CacheSubscribed
300 { _cacheSubscribed_subscribers = subscribers
301 , _cacheSubscribed_parent = parentSub
302 , _cacheSubscribed_occurrence = occRef
304 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
305 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
306 return subscribedTicket
308 subscribed <- getFastWeakTicketValue subscribedTicket
309 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
310 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
311 let es = EventSubscription
312 { _eventSubscription_unsubscribe = do
313 FastWeakBag.remove ticket
314 isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
316 writeIORef mSubscribedRef emptyFastWeak
317 unsubscribe $ _cacheSubscribed_parent subscribed
319 touch subscribedTicket
320 , _eventSubscription_subscribed = EventSubscribed
321 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
322 , eventSubscribedRetained = toAny subscribedTicket
327subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
328subscribe e s = fst <$> subscribeAndRead e s
331wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
332wrap tag getSpecificSubscribed sub = do
333 (sln, subd, occ) <- getSpecificSubscribed sub
335 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
337eventRoot :: GCompare k => k a -> Root x k -> Event x a
338eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
340eventNever :: Event x a
341eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
343eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
344eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
346eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
347eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
349eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
350eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
352eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
353eventHold !h = Event $ subscribeHoldEvent h
355eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
356eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
358{-# INLINE subscribeCoincidenceInner #-}
359subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)
360subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
361 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
362 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
363 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
364 let height = max innerHeight outerHeight
365 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
366 return (innerOcc, height, innerSubd)
368--------------------------------------------------------------------------------
370--------------------------------------------------------------------------------
372data Subscriber x a = Subscriber
373 { subscriberPropagate :: !(a -> EventM x ())
374 , subscriberInvalidateHeight :: !(Height -> IO ())
375 , subscriberRecalculateHeight :: !(Height -> IO ())
378--TODO: Move this comment to WeakBag
379-- These function are constructor functions that are marked NOINLINE so they are
380-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
381-- so any weak references that are attached to the constructors will have their
382-- finalizer run. Using the opaque constructor, does not see the
383-- constructor application, so it behaves like an IORef and cannot be fused away.
385-- The result is also evaluated to WHNF, since forcing a thunk invalidates
386-- the weak pointer to it in some cases.
388newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
389newSubscriberHold h = return $ Subscriber
390 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
391 , subscriberInvalidateHeight = \_ -> return ()
392 , subscriberRecalculateHeight = \_ -> return ()
395newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
396newSubscriberFan subscribed = return $ Subscriber
397 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
398 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
399 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
400 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
401 scheduleClear $ fanSubscribedOccurrence subscribed
402 let f _ (Pair (Identity v) subsubs) = do
403 propagate v $ _fanSubscribedChildren_list subsubs
405 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
407 , subscriberInvalidateHeight = \old -> do
408 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
409 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
410 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
411 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
412 , subscriberRecalculateHeight = \new -> do
413 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
414 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
415 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
416 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
419newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
420newSubscriberSwitch subscribed = return $ Subscriber
421 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
422 tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
423 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
424 scheduleClear $ switchSubscribedOccurrence subscribed
425 propagate a $ switchSubscribedSubscribers subscribed
426 , subscriberInvalidateHeight = \_ -> do
427 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
428 oldHeight <- readIORef $ switchSubscribedHeight subscribed
429 when (oldHeight /= invalidHeight) $ do
430 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
431 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
432 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
433 , subscriberRecalculateHeight = \new -> do
434 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
435 updateSwitchHeight new subscribed
436 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
439newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
440newSubscriberCoincidenceOuter subscribed = return $ Subscriber
441 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
442 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
443 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
444 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
445 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
446 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
447 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
448 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
449 scheduleClear $ coincidenceSubscribedInnerParent subscribed
452 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
453 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
454 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
455 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
456 Just o -> do -- Since it's already firing, no need to adjust height
457 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
458 scheduleClear $ coincidenceSubscribedOccurrence subscribed
459 propagate o $ coincidenceSubscribedSubscribers subscribed
460 , subscriberInvalidateHeight = \_ -> do
461 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
462 invalidateCoincidenceHeight subscribed
463 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
464 , subscriberRecalculateHeight = \_ -> do
465 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
466 recalculateCoincidenceHeight subscribed
467 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
470newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
471newSubscriberCoincidenceInner subscribed = return $ Subscriber
472 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
473 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
474 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
476 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
478 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
479 scheduleClear $ coincidenceSubscribedOccurrence subscribed
480 propagate a $ coincidenceSubscribedSubscribers subscribed
481 , subscriberInvalidateHeight = \_ -> do
482 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
483 invalidateCoincidenceHeight subscribed
484 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
485 , subscriberRecalculateHeight = \_ -> do
486 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
487 recalculateCoincidenceHeight subscribed
488 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
491invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
492invalidateSubscriberHeight = flip subscriberInvalidateHeight
494recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
495recalculateSubscriberHeight = flip subscriberRecalculateHeight
497-- | Propagate everything at the current height
498propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
499propagate a subscribers = withIncreasedDepth $ do
500 -- 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
501 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
502 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
504-- | Propagate everything at the current height
505propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
506propagateFast a subscribers = withIncreasedDepth $ do
507 -- 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
508 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
509 FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
511--------------------------------------------------------------------------------
513--------------------------------------------------------------------------------
518data EventSubscribed x = EventSubscribed
519 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
520 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
522 , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
523 , eventSubscribedHasOwnHeightRef :: !Bool
524 , eventSubscribedWhoCreated :: !(IO [String])
528eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
529eventSubscribedRoot !r = EventSubscribed
530 { eventSubscribedHeightRef = zeroRef
531 , eventSubscribedRetained = toAny r
533 , eventSubscribedGetParents = return []
534 , eventSubscribedHasOwnHeightRef = False
535 , eventSubscribedWhoCreated = return ["root"]
539eventSubscribedNever :: EventSubscribed x
540eventSubscribedNever = EventSubscribed
541 { eventSubscribedHeightRef = zeroRef
542 , eventSubscribedRetained = toAny ()
544 , eventSubscribedGetParents = return []
545 , eventSubscribedHasOwnHeightRef = False
546 , eventSubscribedWhoCreated = return ["never"]
550eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
551eventSubscribedFan !subscribed = EventSubscribed
552 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
553 , eventSubscribedRetained = toAny subscribed
555 , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
556 , eventSubscribedHasOwnHeightRef = False
557 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
561eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
562eventSubscribedSwitch !subscribed = EventSubscribed
563 { eventSubscribedHeightRef = switchSubscribedHeight subscribed
564 , eventSubscribedRetained = toAny subscribed
566 , eventSubscribedGetParents = do
567 s <- readIORef $ switchSubscribedCurrentParent subscribed
568 return [Some.This $ _eventSubscription_subscribed s]
569 , eventSubscribedHasOwnHeightRef = True
570 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
574eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
575eventSubscribedCoincidence !subscribed = EventSubscribed
576 { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
577 , eventSubscribedRetained = toAny subscribed
579 , eventSubscribedGetParents = do
580 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
581 let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
582 innerParents = maybeToList $ fmap Some.This innerSubscription
583 return $ outerParent : innerParents
584 , eventSubscribedHasOwnHeightRef = True
585 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
589getEventSubscribedHeight :: EventSubscribed x -> IO Height
590getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
593whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
594whoCreatedEventSubscribed = eventSubscribedWhoCreated
596walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
597walkInvalidHeightParents s0 = do
598 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
599 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
600 when (h == invalidHeight) $ do
601 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
602 modify (Some.This s :)
603 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
604 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
608{-# INLINE subscribeHoldEvent #-}
609subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
610subscribeHoldEvent = subscribeAndRead . holdEvent
612--------------------------------------------------------------------------------
614--------------------------------------------------------------------------------
616newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
618behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
619behaviorHold !h = Behavior $ readHoldTracked h
621behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
622behaviorHoldIdentity = behaviorHold
624behaviorConst :: a -> Behavior x a
625behaviorConst !a = Behavior $ return a
627behaviorPull :: Pull x a -> Behavior x a
628behaviorPull !p = Behavior $ do
629 val <- liftIO $ readIORef $ pullValue p
631 Just subscribed -> do
632 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
633 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
634 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
635 return $ pullSubscribedValue subscribed
637 i <- liftIO $ newInvalidatorPull p
638 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
639 parentsRef <- liftIO $ newIORef []
640 holdInits <- askBehaviorHoldInits
641 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
642 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
643 parents <- liftIO $ readIORef parentsRef
644 let subscribed = PullSubscribed
645 { pullSubscribedValue = a
646 , pullSubscribedInvalidators = invsRef
647 , pullSubscribedOwnInvalidator = i
648 , pullSubscribedParents = parents
650 liftIO $ writeIORef (pullValue p) $ Just subscribed
651 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
654behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
655behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
657{-# INLINE readHoldTracked #-}
658readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
659readHoldTracked h = do
660 result <- liftIO $ readIORef $ holdValue h
661 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
662 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
665{-# INLINABLE readBehaviorUntracked #-}
666readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
667readBehaviorUntracked b = do
668 holdInits <- getDeferralQueue
669 liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
671--------------------------------------------------------------------------------
673--------------------------------------------------------------------------------
675data Dynamic x p = Dynamic
676 { dynamicCurrent :: !(Behavior x (PatchTarget p))
677 , dynamicUpdated :: !(Event x p)
680dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
681dynamicHold !h = Dynamic
682 { dynamicCurrent = behaviorHold h
683 , dynamicUpdated = eventHold h
686dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
687dynamicHoldIdentity = dynamicHold
689dynamicConst :: PatchTarget p -> Dynamic x p
690dynamicConst !a = Dynamic
691 { dynamicCurrent = behaviorConst a
692 , dynamicUpdated = eventNever
695dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
696dynamicDyn !d = Dynamic
697 { dynamicCurrent = behaviorDyn d
698 , dynamicUpdated = eventDyn d
701dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
702dynamicDynIdentity = dynamicDyn
704--------------------------------------------------------------------------------
706--------------------------------------------------------------------------------
708--TODO: Figure out why certain things are not 'representational', then make them
709--representational so we can use coerce
711--type role Hold representational
713 = Hold { holdValue :: !(IORef (PatchTarget p))
714 , holdInvalidators :: !(IORef [Weak (Invalidator x)])
715 , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
716 , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
722-- | A statically allocated 'SpiderTimeline'; this is the only instance of
723-- 'SpiderTimeline' that can used when using
724-- -fspecialize-to-spidertimeline-global.
727{-# NOINLINE globalSpiderTimelineEnv #-}
728globalSpiderTimelineEnv :: SpiderTimelineEnv Global
729globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
731-- | Stores all global data relevant to a particular Spider timeline; only one
732-- value should exist for each type @x@
733data SpiderTimelineEnv x = SpiderTimelineEnv
734 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
735 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
737 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
740type role SpiderTimelineEnv nominal
742instance Eq (SpiderTimelineEnv x) where
743 _ == _ = True -- Since only one exists of each type
745instance GEq SpiderTimelineEnv where
746#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
748 geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
749 then case unsafeCoerce Refl :: a :~: b of
750 Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
753 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
754 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
759 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
760 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
761 , eventEnvDynInits :: !(IORef [SomeDynInit x])
762 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
763 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
764 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
765 , eventEnvRootClears :: !(IORef [SomeRootClear])
766 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
767 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
768 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
771{-# INLINE runEventM #-}
772runEventM :: EventM x a -> IO a
775asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
776asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
778class MonadIO m => Defer a m where
779 getDeferralQueue :: m (IORef [a])
782defer :: Defer a m => a -> m ()
784 q <- getDeferralQueue
785 liftIO $ modifyIORef' q (a:)
787instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
788 {-# INLINE getDeferralQueue #-}
789 getDeferralQueue = asksEventEnv eventEnvAssignments
791instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
792 {-# INLINE getDeferralQueue #-}
793 getDeferralQueue = asksEventEnv eventEnvHoldInits
795instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
796 {-# INLINE getDeferralQueue #-}
797 getDeferralQueue = asksEventEnv eventEnvDynInits
799instance Defer (SomeHoldInit x) (BehaviorM x) where
800 {-# INLINE getDeferralQueue #-}
801 getDeferralQueue = BehaviorM $ asks snd
803instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
804 {-# INLINE getDeferralQueue #-}
805 getDeferralQueue = asksEventEnv eventEnvMergeUpdates
807instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
808 {-# INLINE getDeferralQueue #-}
809 getDeferralQueue = asksEventEnv eventEnvMergeInits
811class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
812 getCurrentHeight :: m Height
813 scheduleMerge :: Height -> EventM x () -> m ()
815instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
816 {-# INLINE getCurrentHeight #-}
817 getCurrentHeight = do
818 heightRef <- asksEventEnv eventEnvCurrentHeight
819 liftIO $ readIORef heightRef
820 {-# INLINE scheduleMerge #-}
821 scheduleMerge height subscribed = do
822 delayedRef <- asksEventEnv eventEnvDelayedMerges
823 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
825#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
826class x ~ Global => HasSpiderTimeline x where
828class HasSpiderTimeline x where
830 -- | Retrieve the current SpiderTimelineEnv
831 spiderTimeline :: SpiderTimelineEnv x
833instance HasSpiderTimeline Global where
834 spiderTimeline = globalSpiderTimelineEnv
836putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
837putCurrentHeight h = do
838 heightRef <- asksEventEnv eventEnvCurrentHeight
839 liftIO $ writeIORef heightRef $! h
841instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
842 {-# INLINE getDeferralQueue #-}
843 getDeferralQueue = asksEventEnv eventEnvClears
845{-# INLINE scheduleClear #-}
846scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
847scheduleClear r = defer $ SomeClear r
849instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
850 {-# INLINE getDeferralQueue #-}
851 getDeferralQueue = asksEventEnv eventEnvRootClears
853{-# INLINE scheduleRootClear #-}
854scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
855scheduleRootClear r = defer $ SomeRootClear r
857instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
858 {-# INLINE getDeferralQueue #-}
859 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
861-- Note: hold cannot examine its event until after the phase is over
862{-# INLINE [1] hold #-}
863hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
865 valRef <- liftIO $ newIORef v0
866 invsRef <- liftIO $ newIORef []
867 parentRef <- liftIO $ newIORef Nothing
869 nodeId <- liftIO newNodeId
873 , holdInvalidators = invsRef
875 , holdParent = parentRef
877 , holdNodeId = nodeId
880 defer $ SomeHoldInit h
883{-# INLINE getHoldEventSubscription #-}
884getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)
885getHoldEventSubscription h = do
886 ep <- liftIO $ readIORef $ holdParent h
888 Just subd -> return subd
891 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
892 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
893 liftIO $ writeIORef subscriptionRef $! subscription
897 old <- liftIO $ readIORef $ holdValue h
901 -- Need to evaluate these so that we don't retain the Hold itself
902 v <- liftIO $ evaluate $ holdValue h
903 i <- liftIO $ evaluate $ holdInvalidators h
904 defer $ SomeAssignment v i new
905 liftIO $ writeIORef (holdParent h) $ Just subscription
908type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
910--type role BehaviorM representational
911-- BehaviorM can sample behaviors
912newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
914instance Monad (BehaviorM x) where
916 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
918 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
919 {-# INLINE return #-}
920 return x = BehaviorM $ return x
922 fail s = BehaviorM $ fail s
924data BehaviorSubscribed x a
925 = forall p. BehaviorSubscribedHold (Hold x p)
926 | BehaviorSubscribedPull (PullSubscribed x a)
928data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
930--type role PullSubscribed representational
931data PullSubscribed x a
932 = PullSubscribed { pullSubscribedValue :: !a
933 , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
934 , pullSubscribedOwnInvalidator :: !(Invalidator x)
935 , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
938--type role Pull representational
940 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
941 , pullCompute :: !(BehaviorM x a)
948 = forall a. InvalidatorPull (Pull x a)
949 | forall a. InvalidatorSwitch (SwitchSubscribed x a)
951data RootSubscribed x a = forall k. GCompare k => RootSubscribed
952 { rootSubscribedKey :: !(k a)
953 , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
954 , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
955 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
956 , rootSubscribedUninit :: IO ()
957 , 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?
959 , rootSubscribedNodeId :: Int
963data Root x (k :: * -> *)
964 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
965 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
966 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
969data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
971data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
973data SomeMergeUpdate x = SomeMergeUpdate
974 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
975 , _someMergeUpdate_invalidateHeight :: !(IO ())
976 , _someMergeUpdate_recalculateHeight :: !(IO ())
979newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
981-- EventM can do everything BehaviorM can, plus create holds
982newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
984newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x], IORef [SomeDynInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
986instance Defer (SomeHoldInit x) (ComputeM x) where
987 getDeferralQueue = ComputeM $ asks fst
989instance Defer (SomeDynInit x) (ComputeM x) where
990 getDeferralQueue = ComputeM $ asks snd
992{-# INLINABLE runComputeM #-}
993runComputeM :: (Defer (SomeHoldInit x) m, Defer (SomeDynInit x) m) => ComputeM x a -> m a
994runComputeM (ComputeM a) = do
995 holds <- getDeferralQueue
996 dyns <- getDeferralQueue
997 liftIO $ runReaderT a (holds, dyns)
999newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1001data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1002 { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1003 , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1006data HeightBag = HeightBag
1007 { _heightBag_size :: {-# UNPACK #-} !Int
1008 , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1010 deriving (Show, Read, Eq, Ord)
1012heightBagEmpty :: HeightBag
1013heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1015heightBagSize :: HeightBag -> Int
1016heightBagSize = _heightBag_size
1018heightBagFromList :: [Height] -> HeightBag
1019heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1021heightBagAdd :: Height -> HeightBag -> HeightBag
1022heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1024heightBagRemove :: Height -> HeightBag -> HeightBag
1025heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1026 Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1027 Just old -> HeightBag (pred s) $ case old of
1028 0 -> IntMap.delete h c
1029 _ -> IntMap.insert h (pred old) c
1031heightBagMax :: HeightBag -> Height
1032heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1033 Just ((h, _), _) -> Height h
1034 Nothing -> zeroHeight
1036heightBagVerify :: HeightBag -> HeightBag
1038heightBagVerify b@(HeightBag s c) = if
1039 | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1040 -> error $ "heightBagVerify: size doesn't match: " <> show b
1041 | unHeight invalidHeight `IntMap.member` c
1042 -> error $ "heightBagVerify: contains invalid height: " <> show b
1048data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1049 { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1050 , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1051 , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1054data FanSubscribed (x :: *) k
1055 = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1056 , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1057 , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1058 , fanSubscribedParent :: !(EventSubscription x)
1060 , fanSubscribedNodeId :: Int
1065 = Fan { fanParent :: !(Event x (DMap k Identity))
1066 , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1069data SwitchSubscribed x a
1070 = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1071 , switchSubscribedOccurrence :: !(IORef (Maybe a))
1072 , switchSubscribedHeight :: !(IORef Height)
1073 , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1074 , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1075 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1076 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1077 , switchSubscribedParent :: !(Behavior x (Event x a))
1078 , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1079 , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1081 , switchSubscribedNodeId :: Int
1086 = Switch { switchParent :: !(Behavior x (Event x a))
1087 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1090#ifdef USE_TEMPLATE_HASKELL
1091{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1093data CoincidenceSubscribed x a
1094 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1095 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1096 , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1097 , coincidenceSubscribedHeight :: !(IORef Height)
1098 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1099 , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1100 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1101 , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1103 , coincidenceSubscribedNodeId :: Int
1108 = Coincidence { coincidenceParent :: !(Event x (Event x a))
1109 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1112{-# NOINLINE newInvalidatorSwitch #-}
1113newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1114newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1116{-# NOINLINE newInvalidatorPull #-}
1117newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1118newInvalidatorPull p = return $! InvalidatorPull p
1120instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1121 fmapMaybe f = push $ return . f
1123instance HasSpiderTimeline x => Align (Event x) where
1125 align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1127newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1129newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1130newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1132--TODO: Avoid the duplication between this and R.zipDynWith
1133zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1135 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1136 ec = flip push eab $ \o -> do
1138 This (Identity a) -> do
1139 b <- readBehaviorUntracked $ dynamicCurrent db
1141 That (Identity b) -> do
1142 a <- readBehaviorUntracked $ dynamicCurrent da
1144 These (Identity a) (Identity b) -> return (a, b)
1145 return $ Just $ Identity $ f a b
1146 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1148buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1149buildDynamic readV0 v' = do
1150 result <- liftIO $ newIORef $ Left (readV0, v')
1152 defer $ SomeDynInit d
1155unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1156unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1157 where x = (readV0, v')
1159-- ResultM can read behaviors and events
1160type ResultM = EventM
1162{-# NOINLINE unsafeNewIORef #-}
1163unsafeNewIORef :: a -> b -> IORef b
1164unsafeNewIORef _ b = unsafePerformIO $ newIORef b
1166instance HasSpiderTimeline x => Functor (Event x) where
1167 fmap f = push $ return . Just . f
1169instance Functor (Behavior x) where
1170 fmap f = pull . fmap f . readBehaviorTracked
1173push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1174push f e = cacheEvent (pushCheap f e)
1176{-# INLINABLE pull #-}
1177pull :: BehaviorM x a -> Behavior x a
1178pull a = behaviorPull $ Pull
1180 , pullValue = unsafeNewIORef a Nothing
1182 , pullNodeId = unsafeNodeId a
1186{-# INLINABLE switch #-}
1187switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1188switch a = eventSwitch $ Switch
1190 , switchSubscribed = unsafeNewIORef a Nothing
1193coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1194coincidence a = eventCoincidence $ Coincidence
1195 { coincidenceParent = a
1196 , coincidenceSubscribed = unsafeNewIORef a Nothing
1199-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1200run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1202 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1204 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1205 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1206 occBefore <- liftIO $ do
1207 occBefore <- readIORef occRef
1208 writeIORef occRef $! DMap.insert k a occBefore
1210 if DMap.null occBefore
1211 then do scheduleRootClear occRef
1214 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1215 propagate a subscribersRef
1216 delayedRef <- asksEventEnv eventEnvDelayedMerges
1218 delayed <- liftIO $ readIORef delayedRef
1219 case IntMap.minViewWithKey delayed of
1220 Nothing -> return ()
1221 Just ((currentHeight, cur), future) -> do
1222 tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1223 putCurrentHeight $ Height currentHeight
1224 liftIO $ writeIORef delayedRef $! future
1228 putCurrentHeight maxBound
1230 tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1233scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1234scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1235 height <- liftIO $ readIORef heightRef
1236 currentHeight <- getCurrentHeight
1237 case height `compare` currentHeight of
1238 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1239 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1242data SomeClear = forall a. SomeClear (IORef (Maybe a))
1244data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1246data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1248debugFinalize :: Bool
1249debugFinalize = False
1251mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1252mkWeakPtrWithDebug x debugNote = do
1256 then Just $ putStrLn $ "finalizing: " ++ debugNote
1259type WeakList a = [Weak a]
1261{-# INLINE withIncreasedDepth #-}
1263withIncreasedDepth :: CanTrace x m => m a -> m a
1264withIncreasedDepth a = do
1265 spiderTimeline <- askSpiderTimelineEnv
1266 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1268 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1271withIncreasedDepth :: m a -> m a
1272withIncreasedDepth = id
1275type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1277{-# INLINE tracePropagate #-}
1278tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1279tracePropagate p = traceWhen p debugPropagate
1281{-# INLINE traceInvalidate #-}
1282traceInvalidate :: String -> IO ()
1283traceInvalidate = when debugInvalidate . liftIO . putStrLn
1285{-# INLINE traceWhen #-}
1286traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1287traceWhen p b message = traceMWhen p b $ return message
1289{-# INLINE traceMWhen #-}
1290traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1291traceMWhen _ b getMessage = when b $ do
1292 message <- getMessage
1294 spiderTimeline <- askSpiderTimelineEnv
1295 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1299 liftIO $ putStrLn $ replicate d ' ' <> message
1301whoCreatedIORef :: IORef a -> IO [String]
1302whoCreatedIORef (IORef a) = whoCreated $! a
1305groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1308 (x :| xs) : t -> case groupByHead t of
1309 [] -> [(x, xs :| [])]
1311 | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1312 | otherwise -> (x, xs :| []) : l
1314listsToForest :: Eq a => [[a]] -> Forest a
1315listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1318{-# INLINE propagateSubscriberHold #-}
1319propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1320propagateSubscriberHold h a = do
1321 {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1322 invalidators <- liftIO $ readIORef $ holdInvalidators h
1323 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1324 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1325 case {-# SCC "apply" #-} apply a v of
1326 Nothing -> return ()
1328 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1329 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1330 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1331 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1333data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1335runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1336runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1338askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1340 (!m, _) <- BehaviorM ask
1342 Nothing -> return Nothing
1343 Just (!wi, _) -> return $ Just wi
1345askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1347 (!m, _) <- BehaviorM ask
1349 Nothing -> return Nothing
1350 Just (_, !p) -> return $ Just p
1352askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1353askBehaviorHoldInits = do
1354 (_, !his) <- BehaviorM ask
1357{-# INLINE getDynHold #-}
1358getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1360 mh <- liftIO $ readIORef $ unDyn d
1363 Left (readV0, v') -> do
1364 holdInits <- getDeferralQueue
1365 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1367 liftIO $ writeIORef (unDyn d) $ Right h
1370-- Always refers to 0
1371{-# NOINLINE zeroRef #-}
1372zeroRef :: IORef Height
1373zeroRef = unsafePerformIO $ newIORef zeroHeight
1375type CanSubscribe x m =
1376 ( HasSpiderTimeline x
1377 , HasCurrentHeight x m
1378 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
1379 , Defer SomeClear m -- Wiping out event firings
1380 , Defer (SomeAssignment x) m -- Updating state
1381 , Defer (SomeResetCoincidence x) m
1385getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1386getRootSubscribed k r sub = do
1387 mSubscribed <- readIORef $ rootSubscribed r
1388 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1389 case DMap.lookup k mSubscribed of
1390 Just subscribed -> {-# SCC "hitRoot" #-} do
1391 sln <- subscribeRootSubscribed subscribed sub
1393 return (sln, subscribed, occ)
1394 Nothing -> {-# SCC "missRoot" #-} do
1395 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1396 let !cached = rootSubscribed r
1397 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1398 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1399 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1400 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1401 writeIORef uninitRef $! uninit
1402 let !subscribed = RootSubscribed
1403 { rootSubscribedKey = k
1404 , rootSubscribedCachedSubscribed = cached
1405 , rootSubscribedOccurrence = getOcc
1406 , rootSubscribedSubscribers = subs
1407 , rootSubscribedUninit = uninit
1408 , rootSubscribedWeakSelf = weakSelf
1410 , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1413 -- If we die at the same moment that all our children die, they will
1414 -- try to clean us up but will fail because their Weak reference to us
1415 -- will also be dead. So, if we are dying, check if there are any
1416 -- children; since children don't bother cleaning themselves up if
1417 -- their parents are already dead, I don't think there's a race
1418 -- condition here. However, if there are any children, then we can
1419 -- infer that we need to clean ourselves up, so we do.
1421 cs <- readIORef $ _weakBag_children subs
1422 when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1423 writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1424 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
1426 return (sln, subscribed, occ)
1428#ifdef USE_TEMPLATE_HASKELL
1429{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1431cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1432cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1433 rootSubscribedUninit self
1434 modifyIORef' cached $ DMap.delete k
1436{-# INLINE subscribeRootSubscribed #-}
1437subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1438subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1440{-# INLINABLE getFanSubscribed #-}
1441getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
1442getFanSubscribed k f sub = do
1443 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1445 Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1446 sln <- subscribeFanSubscribed k subscribed sub
1447 occ <- readIORef $ fanSubscribedOccurrence subscribed
1448 return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1449 Nothing -> {-# SCC "missFan" #-} do
1450 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1451 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1452 s <- liftIO $ newSubscriberFan subscribedUnsafe
1453 (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1454 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1455 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1456 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1457 occRef <- liftIO $ newIORef parentOcc
1458 when (isJust parentOcc) $ scheduleClear occRef
1459 let subscribed = FanSubscribed
1460 { fanSubscribedCachedSubscribed = fanSubscribed f
1461 , fanSubscribedOccurrence = occRef
1462 , fanSubscribedParent = subscription
1463 , fanSubscribedSubscribers = subscribersRef
1465 , fanSubscribedNodeId = unsafeNodeId f
1468 let !self = (k, subscribed)
1469 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1470 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1471 liftIO $ writeIORef subscribedRef $! subscribed
1472 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1473 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1475cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1476cleanupFanSubscribed (k, subscribed) = do
1477 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1478 let reducedSubscribers = DMap.delete k subscribers
1479 if DMap.null reducedSubscribers
1481 unsubscribe $ fanSubscribedParent subscribed
1482 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1483 writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1484 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1486{-# INLINE subscribeFanSubscribed #-}
1487subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1488subscribeFanSubscribed k subscribed sub = do
1489 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1490 case DMap.lookup k subscribers of
1491 Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1492 let !self = (k, subscribed)
1493 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1494 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1495 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
1497 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1499{-# INLINABLE getSwitchSubscribed #-}
1500getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1501getSwitchSubscribed s sub = do
1502 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1504 Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1505 sln <- subscribeSwitchSubscribed subscribed sub
1506 occ <- readIORef $ switchSubscribedOccurrence subscribed
1507 return (sln, subscribed, occ)
1508 Nothing -> {-# SCC "missSwitch" #-} do
1509 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1510 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1511 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1512 mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1513 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1514 wiRef <- liftIO $ newIORef wi
1515 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1516 holdInits <- getDeferralQueue
1517 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1518 (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1519 heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1520 subscriptionRef <- liftIO $ newIORef subscription
1521 occRef <- liftIO $ newIORef parentOcc
1522 when (isJust parentOcc) $ scheduleClear occRef
1523 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1524 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1525 let !subscribed = SwitchSubscribed
1526 { switchSubscribedCachedSubscribed = switchSubscribed s
1527 , switchSubscribedOccurrence = occRef
1528 , switchSubscribedHeight = heightRef
1529 , switchSubscribedSubscribers = subs
1530 , switchSubscribedOwnInvalidator = i
1531 , switchSubscribedOwnWeakInvalidator = wiRef
1532 , switchSubscribedBehaviorParents = parentsRef
1533 , switchSubscribedParent = switchParent s
1534 , switchSubscribedCurrentParent = subscriptionRef
1535 , switchSubscribedWeakSelf = weakSelf
1537 , switchSubscribedNodeId = unsafeNodeId s
1540 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1541 liftIO $ writeIORef subscribedRef $! subscribed
1542 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1543 return (slnForSub, subscribed, parentOcc)
1545cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1546cleanupSwitchSubscribed subscribed = do
1547 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1548 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1549 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1551{-# INLINE subscribeSwitchSubscribed #-}
1552subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1553subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1555{-# INLINABLE getCoincidenceSubscribed #-}
1556getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1557getCoincidenceSubscribed c sub = do
1558 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1560 Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1561 sln <- subscribeCoincidenceSubscribed subscribed sub
1562 occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1563 return (sln, subscribed, occ)
1564 Nothing -> {-# SCC "missCoincidence" #-} do
1565 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1566 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1567 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1568 (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1569 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1570 (occ, height, mInnerSubd) <- case outerOcc of
1571 Nothing -> return (Nothing, outerHeight, Nothing)
1573 (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1574 return (occ, height, Just innerSubd)
1575 occRef <- liftIO $ newIORef occ
1576 when (isJust occ) $ scheduleClear occRef
1577 heightRef <- liftIO $ newIORef height
1578 innerSubdRef <- liftIO $ newIORef mInnerSubd
1579 scheduleClear innerSubdRef
1580 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1581 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1582 let subscribed = CoincidenceSubscribed
1583 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1584 , coincidenceSubscribedOccurrence = occRef
1585 , coincidenceSubscribedHeight = heightRef
1586 , coincidenceSubscribedSubscribers = subs
1587 , coincidenceSubscribedOuter = subOuter
1588 , coincidenceSubscribedOuterParent = outerSubscription
1589 , coincidenceSubscribedInnerParent = innerSubdRef
1590 , coincidenceSubscribedWeakSelf = weakSelf
1592 , coincidenceSubscribedNodeId = unsafeNodeId c
1595 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1596 liftIO $ writeIORef subscribedRef $! subscribed
1597 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1598 return (slnForSub, subscribed, occ)
1600cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1601cleanupCoincidenceSubscribed subscribed = do
1602 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1603 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1605{-# INLINE subscribeCoincidenceSubscribed #-}
1606subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1607subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1610merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1611merge d = cacheEvent (mergeCheap d)
1613{-# INLINE mergeWithMove #-}
1614mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1615mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1617{-# INLINE [1] mergeCheap #-}
1618mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1619mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size
1621 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1622 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1623 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1624 (mOldSubd, newPs) <- case me of
1625 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1627 let s = subscriber $ return k
1628 subscription@(EventSubscription _ subd) <- subscribe e s
1629 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1630 let newParent = MergeSubscribedParent subscription
1631 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1632 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1633 forM_ mOldSubd $ \oldSubd -> do
1634 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1635 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1636 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1637 foldM f ([], oldParents) $ DMap.toList p
1638 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1639 getInitialSubscribers initialParents subscriber = do
1640 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1641 let s = subscriber $ return k
1642 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1643 height <- liftIO $ getEventSubscribedHeight parentSubd
1644 return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1645 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1646 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1647 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1649 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1650 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1652{-# INLINE [1] mergeCheapWithMove #-}
1653mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1654mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size
1656 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1657 updateMe subscriber heightBagRef oldParents p = do
1658 -- Prepare new parents for insertion
1659 let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1660 subscribeParent k e = do
1661 keyRef <- liftIO $ newIORef k
1662 let s = subscriber $ liftIO $ readIORef keyRef
1663 subscription@(EventSubscription _ subd) <- subscribe e s
1665 newParentHeight <- getEventSubscribedHeight subd
1666 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1667 return $ MergeSubscribedParentWithMove subscription keyRef
1668 p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1669 -- Collect old parents for deletion and update the keys of moved parents
1670 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1671 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1673 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1674 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1675 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1677 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1679 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1680 return (toDelete, applyAlways p' oldParents)
1681 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1682 getInitialSubscribers initialParents subscriber = do
1683 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1684 keyRef <- liftIO $ newIORef k
1685 let s = subscriber $ liftIO $ readIORef keyRef
1686 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1687 height <- liftIO $ getEventSubscribedHeight parentSubd
1688 return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1689 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1690 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1691 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1693 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1694 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1696type MergeUpdateFunc k x p s
1697 = (forall a. EventM x (k a) -> Subscriber x a)
1701 -> EventM x ([EventSubscription x], DMap k s)
1703type MergeInitFunc k x s
1705 -> (forall a. EventM x (k a) -> Subscriber x a)
1706 -> EventM x (DMap k Identity, [Height], DMap k s)
1708type MergeDestroyFunc k s
1712{-# INLINE mergeCheap' #-}
1713mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> (DMap k s -> Int) -> Dynamic x p -> Event x (DMap k Identity)
1714mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do
1715 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1716 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1717 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1718 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1719 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1720 let scheduleSelf height = scheduleMerge' height heightRef $ do
1721 m <- liftIO $ readIORef accumRef
1722 liftIO $ writeIORef accumRef $! DMap.empty
1723 --TODO: Assert that m is not empty
1724 subscriberPropagate sub m
1725 invalidateMyHeight = do
1726 oldHeight <- readIORef heightRef
1727 when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1728 writeIORef heightRef $! invalidHeight
1729 subscriberInvalidateHeight sub oldHeight
1730 revalidateMyHeight = do
1731 currentHeight <- readIORef heightRef
1732 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1733 heights <- readIORef heightBagRef
1734 parents <- readIORef parentsRef
1735 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1736 case heightBagSize heights `compare` numParents parents of
1739 let height = succHeight $ heightBagMax heights
1740 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1741 writeIORef heightRef $! height
1742 subscriberRecalculateHeight sub height
1743 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (numParents parents) <> ") for Merge"
1744 subscriber :: forall a. EventM x (k a) -> Subscriber x a
1745 subscriber getKey = Subscriber
1746 { subscriberPropagate = \a -> do
1747 oldM <- liftIO $ readIORef accumRef
1749 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1750 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1751 liftIO $ writeIORef accumRef $! newM
1752 when (DMap.null oldM) $ do -- Only schedule the firing once
1753 height <- liftIO $ readIORef heightRef
1754 --TODO: assertions about height
1755 currentHeight <- getCurrentHeight
1756 when (height <= currentHeight) $ do
1757 if height /= invalidHeight
1759 myStack <- liftIO $ whoCreatedIORef undefined --TODO
1760 error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1763 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1764 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1765 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1769 error $ "Causality loop found" <> cycleInfo
1771 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1772 modifyIORef' heightBagRef $ heightBagRemove old
1774 , subscriberRecalculateHeight = \new -> do
1775 modifyIORef' heightBagRef $ heightBagAdd new
1779 oldParents <- liftIO $ readIORef parentsRef
1780 (subscriptionsToKill, newParents) <- updateFunc subscriber heightBagRef oldParents x
1781 liftIO $ writeIORef parentsRef $! newParents
1782 return subscriptionsToKill
1783 (dm, heights, initialParentState) <- getInitialSubscribers initialParents subscriber
1784 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1785 myHeight = if invalidHeight `elem` heights
1787 else succHeight $ heightBagMax myHeightBag
1788 currentHeight <- getCurrentHeight
1789 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1790 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1792 unless (DMap.null accum) $ do
1793 scheduleSelf myHeight
1794 occRef <- liftIO $ newIORef occ
1795 when (isJust occ) $ scheduleClear occRef
1796 liftIO $ writeIORef accumRef $! accum
1797 liftIO $ writeIORef heightRef $! myHeight
1798 liftIO $ writeIORef heightBagRef $! myHeightBag
1799 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1800 liftIO $ writeIORef parentsRef $! initialParentState
1801 defer $ SomeMergeInit $ do
1803 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1804 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1805 defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight
1806 , subscriberInvalidateHeight = \_ -> return ()
1807 , subscriberRecalculateHeight = \_ -> return ()
1809 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1810 forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight
1811 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1812 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1813 -- its subscription.
1814 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1815 let unsubscribeAll = destroy =<< readIORef parentsRef
1816 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1820newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
1822fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
1826 , fanSubscribed = unsafeNewIORef e Nothing
1828 in EventSelector $ \k -> eventFan k f
1830runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
1831runHoldInits holdInitRef dynInitRef mergeInitRef = do
1832 holdInits <- liftIO $ readIORef holdInitRef
1833 dynInits <- liftIO $ readIORef dynInitRef
1834 mergeInits <- liftIO $ readIORef mergeInitRef
1835 unless (null holdInits && null dynInits && null mergeInits) $ do
1836 liftIO $ writeIORef holdInitRef []
1837 liftIO $ writeIORef dynInitRef []
1838 liftIO $ writeIORef mergeInitRef []
1839 mapM_ initHold holdInits
1840 mapM_ initDyn dynInits
1841 mapM_ unSomeMergeInit mergeInits
1842 runHoldInits holdInitRef dynInitRef mergeInitRef
1844initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
1845initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1847initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
1848initDyn (SomeDynInit d) = void $ getDynHold d
1850newEventEnv :: IO (EventEnv x)
1852 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1853 holdInitRef <- newIORef []
1854 dynInitRef <- newIORef []
1855 mergeUpdateRef <- newIORef []
1856 mergeInitRef <- newIORef []
1857 heightRef <- newIORef zeroHeight
1858 toClearRef <- newIORef []
1859 toClearRootRef <- newIORef []
1860 coincidenceInfosRef <- newIORef []
1861 delayedRef <- newIORef IntMap.empty
1862 return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1864clearEventEnv :: EventEnv x -> IO ()
1865clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
1866 writeIORef toAssignRef []
1867 writeIORef holdInitRef []
1868 writeIORef dynInitRef []
1869 writeIORef mergeUpdateRef []
1870 writeIORef mergeInitRef []
1871 writeIORef heightRef zeroHeight
1872 writeIORef toClearRef []
1873 writeIORef toClearRootRef []
1874 writeIORef coincidenceInfosRef []
1875 writeIORef delayedRef IntMap.empty
1877-- | Run an event action outside of a frame
1878runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1879runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
1880 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
1883 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
1885 result <- runEventM go
1886 toClear <- readIORef $ eventEnvClears env
1887 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1888 toClearRoot <- readIORef $ eventEnvRootClears env
1889 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1890 toAssign <- readIORef $ eventEnvAssignments env
1891 toReconnectRef <- newIORef []
1892 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
1893 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1895 when debugInvalidate $ putStrLn $ "Invalidating Hold"
1896 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1897 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
1898 writeIORef (eventEnvMergeUpdates env) []
1899 when debugPropagate $ putStrLn "Updating merges"
1900 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
1901 when debugPropagate $ putStrLn "Updating merges done"
1902 toReconnect <- readIORef toReconnectRef
1904 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1905 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1906 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1907 when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
1909 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1910 wi' <- mkWeakPtrWithDebug i "wi'"
1911 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
1912 writeIORef (switchSubscribedBehaviorParents subscribed) []
1913 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
1914 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
1915 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
1916 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1917 sub <- newSubscriberSwitch subscribed
1918 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --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
1920 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1921 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1922 EventRoot _ -> "EventRoot"
1923 EventNever -> "EventNever"
1924 _ -> "something else"
1926 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1927 return oldSubscription
1928 liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
1929 liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
1930 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1931 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1932 parentHeight <- getEventSubscribedHeight subd'
1933 myHeight <- readIORef $ switchSubscribedHeight subscribed
1934 when (parentHeight /= myHeight) $ do
1935 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1936 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1937 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
1938 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1939 unsubscribe subscription
1940 mapM_ invalidateCoincidenceHeight mcs
1941 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1942 mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
1943 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1944 height <- calculateSwitchHeight subscribed
1945 updateSwitchHeight height subscribed
1948newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1950{-# INLINE zeroHeight #-}
1952zeroHeight = Height 0
1954{-# INLINE invalidHeight #-}
1955invalidHeight :: Height
1956invalidHeight = Height (-1000)
1959-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1960{-# INLINE invalidHeightBeingTraversed #-}
1961invalidHeightBeingTraversed :: Height
1962invalidHeightBeingTraversed = Height (-1001)
1965{-# INLINE succHeight #-}
1966succHeight :: Height -> Height
1967succHeight h@(Height a) =
1968 if h == invalidHeight
1970 else Height $ succ a
1972invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1973invalidateCoincidenceHeight subscribed = do
1974 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1975 when (oldHeight /= invalidHeight) $ do
1976 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
1977 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1979updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
1980updateSwitchHeight new subscribed = do
1981 oldHeight <- readIORef $ switchSubscribedHeight subscribed
1982 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1983 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1984 writeIORef (switchSubscribedHeight subscribed) $! new
1985 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1987recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1988recalculateCoincidenceHeight subscribed = do
1989 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1990 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1991 height <- calculateCoincidenceHeight subscribed
1992 when (height /= invalidHeight) $ do
1993 writeIORef (coincidenceSubscribedHeight subscribed) $! height
1994 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1996calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
1997calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1999calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2000calculateCoincidenceHeight subscribed = do
2001 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2002 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2003 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2005data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2007invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2008invalidate toReconnectRef wis = do
2009 forM_ wis $ \wi -> do
2013 traceInvalidate "invalidate Dead"
2014 return () --TODO: Should we clean this up here?
2016 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2018 InvalidatorPull p -> do
2019 traceInvalidate $ "invalidate: Pull" <> showNodeId p
2020 mVal <- readIORef $ pullValue p
2021 forM_ mVal $ \val -> do
2022 writeIORef (pullValue p) Nothing
2023 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2024 InvalidatorSwitch subscribed -> do
2025 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2026 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2027 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
2029--------------------------------------------------------------------------------
2030-- Reflex integration
2031--------------------------------------------------------------------------------
2033#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2034-- When we're specializing, we include this from Reflex.Class instead, because
2035-- it needs access to these types; when we're not, we want them here, so our
2036-- instance isn't an orphan instance.
2037#include "SpiderTimeline.include.hs"
2038#include "SpiderTimelineHost.include.hs"
2041unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2042unsafeNewSpiderTimelineEnv = do
2046 depthRef <- newIORef 0
2048 return $ SpiderTimelineEnv
2049 { _spiderTimeline_lock = lock
2050 , _spiderTimeline_eventEnv = env
2052 , _spiderTimeline_depth = depthRef
2056#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2057-- | Create a new SpiderTimelineEnv
2058newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2059newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2061data LocalSpiderTimeline x s
2063instance Reifies s (SpiderTimelineEnv x) =>
2064 HasSpiderTimeline (LocalSpiderTimeline x s) where
2065 spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2069 -> SpiderTimelineEnv x
2070 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2071localSpiderTimeline _ = unsafeCoerce
2073-- | Pass a new timeline to the given function.
2074withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2075withSpiderTimeline k = do
2076 env <- unsafeNewSpiderTimelineEnv
2077 reify env $ \s -> k $ localSpiderTimeline s env
2080newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2082newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2084#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2085instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2086 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2087 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2088 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2089 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2090 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2091 type PullM (SpiderTimeline x) = SpiderPullM x
2092 type PushM (SpiderTimeline x) = SpiderPushM x
2093 {-# INLINABLE never #-}
2094 never = SpiderEvent eventNever
2095 {-# INLINABLE constant #-}
2096 constant = SpiderBehavior . behaviorConst
2098 push f = SpiderEvent . push (coerce f) . unSpiderEvent
2099 {-# INLINE pushCheap #-}
2100 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2101 {-# INLINABLE pull #-}
2102 pull = SpiderBehavior . pull . coerce
2103 {-# INLINABLE merge #-}
2104 merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2105 {-# INLINABLE fan #-}
2106 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2107 {-# INLINABLE switch #-}
2108 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2109 {-# INLINABLE coincidence #-}
2110 coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2111 {-# INLINABLE current #-}
2112 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2113 {-# INLINABLE updated #-}
2114 updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2115 {-# INLINABLE unsafeBuildDynamic #-}
2116 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2117 {-# INLINABLE unsafeBuildIncremental #-}
2118 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2119 {-# INLINABLE mergeIncremental #-}
2120 mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2121 {-# INLINABLE mergeIncrementalWithMove #-}
2122 mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2123 {-# INLINABLE currentIncremental #-}
2124 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2125 {-# INLINABLE updatedIncremental #-}
2126 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2127 {-# INLINABLE incrementalToDynamic #-}
2128 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2129 c <- readBehaviorUntracked $ dynamicCurrent i
2130 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2131 eventCoercion Coercion = Coercion
2132 behaviorCoercion Coercion = Coercion
2133 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2136data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2138data SpiderEventHandle x a = SpiderEventHandle
2139 { spiderEventHandleSubscription :: EventSubscription x
2140 , spiderEventHandleValue :: IORef (Maybe a)
2143instance MonadRef (EventM x) where
2144 type Ref (EventM x) = Ref IO
2145 {-# INLINABLE newRef #-}
2146 {-# INLINABLE readRef #-}
2147 {-# INLINABLE writeRef #-}
2148 newRef = liftIO . newRef
2149 readRef = liftIO . readRef
2150 writeRef r a = liftIO $ writeRef r a
2152instance MonadAtomicRef (EventM x) where
2153 {-# INLINABLE atomicModifyRef #-}
2154 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2156-- | The monad for actions that manipulate a Spider timeline identified by @x@
2157newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2159instance Monad (SpiderHost x) where
2160 {-# INLINABLE (>>=) #-}
2161 SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2162 {-# INLINABLE (>>) #-}
2163 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2164 {-# INLINABLE return #-}
2165 return x = SpiderHost $ return x
2166 {-# INLINABLE fail #-}
2167 fail s = SpiderHost $ fail s
2169-- | Run an action affecting the global Spider timeline; this will be guarded by
2170-- a mutex for that timeline
2171runSpiderHost :: SpiderHost Global a -> IO a
2172runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2174#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2175-- | Run an action affecting a given Spider timeline; this will be guarded by a
2176-- mutex for that timeline
2177runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2178runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2181newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2183instance Monad (SpiderHostFrame x) where
2184 {-# INLINABLE (>>=) #-}
2185 SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2186 {-# INLINABLE (>>) #-}
2187 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2188 {-# INLINABLE return #-}
2189 return x = SpiderHostFrame $ return x
2190 {-# INLINABLE fail #-}
2191 fail s = SpiderHostFrame $ fail s
2193newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2194newEventWithTriggerIO f = do
2195 es <- newFanEventWithTriggerIO $ \Refl -> f
2196 return $ select es Refl
2198newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2199newFanEventWithTriggerIO f = do
2200 occRef <- newIORef DMap.empty
2201 subscribedRef <- newIORef DMap.empty
2203 { rootOccurrence = occRef
2204 , rootSubscribed = subscribedRef
2207 return $ EventSelector $ \k -> eventRoot k r
2209newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2211instance MonadRef (SpiderHost x) where
2212 type Ref (SpiderHost x) = Ref IO
2213 newRef = SpiderHost . newRef
2214 readRef = SpiderHost . readRef
2215 writeRef r = SpiderHost . writeRef r
2217instance MonadAtomicRef (SpiderHost x) where
2218 atomicModifyRef r = SpiderHost . atomicModifyRef r
2220instance MonadRef (SpiderHostFrame x) where
2221 type Ref (SpiderHostFrame x) = Ref IO
2222 newRef = SpiderHostFrame . newRef
2223 readRef = SpiderHostFrame . readRef
2224 writeRef r = SpiderHostFrame . writeRef r
2226instance MonadAtomicRef (SpiderHostFrame x) where
2227 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2229instance PrimMonad (SpiderHostFrame x) where
2230 type PrimState (SpiderHostFrame x) = PrimState IO
2231 primitive = SpiderHostFrame . EventM . primitive
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