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
60import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
61import qualified Data.FastMutableIntMap as FastMutableIntMap
63import GHC.IORef (IORef (..))
66import Reflex.FunctorMaybe
67import System.IO.Unsafe
72import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
73import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
74import qualified Data.List.NonEmpty as NonEmpty
75import Data.Monoid (mempty)
76import Data.Tree (Forest, Tree (..), drawForest)
79import Data.FastWeakBag (FastWeakBag)
80import qualified Data.FastWeakBag as FastWeakBag
81import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
82import qualified Data.WeakBag as WeakBag
83#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
85import Data.Some (Some)
86import qualified Data.Some as Some
87import Data.Type.Coercion
88import qualified Reflex.Class
89import qualified Reflex.Class as R
90import qualified Reflex.Host.Class
92import Reflex.NotReady.Class
94import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
96-- Note: must come last to silence warnings due to AMP on GHC < 7.10
97import Prelude hiding (any, concat, mapM, mapM_, sequence)
99#ifdef DEBUG_TRACE_EVENTS
100import System.IO (stderr)
101import qualified Data.ByteString.Char8 as BS8
104#ifdef DEBUG_TRACE_EVENTS
106withStackOneLine :: (BS8.ByteString -> a) -> a
107withStackOneLine expr = unsafePerformIO $ do
108 stack <- currentCallStack
109 return (expr (BS8.pack (unwords (reverse stack))))
113debugPropagate :: Bool
115debugInvalidateHeight :: Bool
117debugInvalidate :: Bool
125debugInvalidateHeight = False
127debugInvalidate = True
129class HasNodeId a where
130 getNodeId :: a -> Int
132instance HasNodeId (Hold x p a) where
133 getNodeId = holdNodeId
135instance HasNodeId (PushSubscribed x a b) where
136 getNodeId = pushSubscribedNodeId
138instance HasNodeId (SwitchSubscribed x a) where
139 getNodeId = switchSubscribedNodeId
141instance HasNodeId (FanSubscribed x a) where
142 getNodeId = fanSubscribedNodeId
144instance HasNodeId (CoincidenceSubscribed x a) where
145 getNodeId = coincidenceSubscribedNodeId
147instance HasNodeId (RootSubscribed x a) where
148 getNodeId = rootSubscribedNodeId
150instance HasNodeId (Pull x a) where
151 getNodeId = pullNodeId
153{-# INLINE showNodeId #-}
154showNodeId :: HasNodeId a => a -> String
155showNodeId = ("#"<>) . show . getNodeId
157showSubscriberType :: Subscriber x a -> String
158showSubscriberType = \case
159 SubscriberPush _ _ -> "SubscriberPush"
160 SubscriberMerge _ _ -> "SubscriberMerge"
161 SubscriberFan _ -> "SubscriberFan"
162 SubscriberMergeChange _ -> "SubscriberMergeChange"
163 SubscriberHold _ -> "SubscriberHold"
164 SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
165 SubscriberSwitch _ -> "SubscriberSwitch"
166 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
167 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
168 SubscriberHandle -> "SubscriberHandle"
170showEventType :: Event x a -> String
172 EventRoot _ _ -> "EventRoot"
173 EventNever -> "EventNever"
174 EventPush _ -> "EventPush"
175 EventMerge _ -> "EventMerge"
176 EventFan _ _ -> "EventFan"
177 EventSwitch _ -> "EventSwitch"
178 EventCoincidence _ -> "EventCoincidence"
179 EventHold _ -> "EventHold"
180 EventDyn _ -> "EventDyn"
181 EventHoldIdentity _ -> "EventHoldIdentity"
182 EventDynIdentity _ -> "EventDynIdentity"
186debugPropagate = False
188debugInvalidateHeight = False
190debugInvalidate = False
192-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
193{-# INLINE showNodeId #-}
194showNodeId :: a -> String
200{-# NOINLINE nextNodeIdRef #-}
201nextNodeIdRef :: IORef Int
202nextNodeIdRef = unsafePerformIO $ newIORef 1
205newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
207{-# NOINLINE unsafeNodeId #-}
208unsafeNodeId :: a -> Int
209unsafeNodeId a = unsafePerformIO $ do
214--------------------------------------------------------------------------------
216--------------------------------------------------------------------------------
218--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
219-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
220data EventSubscription x = EventSubscription
221 { _eventSubscription_unsubscribe :: !(IO ())
222 , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
225unsubscribe :: EventSubscription x -> IO ()
226unsubscribe (EventSubscription u _) = u
228--------------------------------------------------------------------------------
230--------------------------------------------------------------------------------
232newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
234{-# INLINE subscribeAndRead #-}
235subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
236subscribeAndRead = unEvent
239"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
240"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
241"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
244-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
245-- caching; if the computation function is very cheap, this is (much) more
246-- efficient than 'push'
247{-# INLINE [1] pushCheap #-}
248pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
249pushCheap !f e = Event $ \sub -> do
250 (subscription, occ) <- subscribeAndRead e $ sub
251 { subscriberPropagate = \a -> do
253 mapM_ (subscriberPropagate sub) mb
255 occ' <- join <$> mapM f occ
256 return (subscription, occ')
258-- | A subscriber that never triggers other 'Event's
259{-# INLINE terminalSubscriber #-}
260terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
261terminalSubscriber p = Subscriber
262 { subscriberPropagate = p
263 , subscriberInvalidateHeight = \_ -> return ()
264 , subscriberRecalculateHeight = \_ -> return ()
267-- | Subscribe to an Event only for the duration of one occurrence
268{-# INLINE subscribeAndReadHead #-}
269subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
270subscribeAndReadHead e sub = do
271 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
272 (subscription, occ) <- subscribeAndRead e $ sub
273 { subscriberPropagate = \a -> do
274 liftIO $ unsubscribe =<< readIORef subscriptionRef
275 subscriberPropagate sub a
278 Nothing -> writeIORef subscriptionRef $! subscription
279 Just _ -> unsubscribe subscription
280 return (subscription, occ)
282--TODO: Make this lazy in its input event
283headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
285 parent <- liftIO $ newIORef $ Just originalE
286 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
287 let clearParent = liftIO $ writeIORef parent Nothing
288 (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
289 when (isJust occ) clearParent
290 return $ Event $ \sub -> do
291 liftIO (readIORef parent) >>= \case
292 Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
293 Just e -> subscribeAndReadHead e sub
295data CacheSubscribed x a
296 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
297 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
298 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
301-- | Construct an 'Event' whose value is guaranteed not to be recomputed
304--TODO: Try a caching strategy where we subscribe directly to the parent when
305--there's only one subscriber, and then build our own FastWeakBag only when a second
307{-# NOINLINE [0] cacheEvent #-}
308cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
310#ifdef DEBUG_TRACE_EVENTS
311 withStackOneLine $ \callSite -> Event $
315 let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
316 !mSubscribedRef = unsafeNewIORef e emptyFastWeak
317 in \sub -> {-# SCC "cacheEvent" #-} do
318#ifdef DEBUG_TRACE_EVENTS
319 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
321 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
322 Just subscribedTicket -> return subscribedTicket
324 subscribers <- liftIO FastWeakBag.empty
325 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
326 (parentSub, occ) <- subscribeAndRead e $ Subscriber
327 { subscriberPropagate = \a -> do
328 liftIO $ writeIORef occRef $ Just a
330 propagateFast a subscribers
331 , subscriberInvalidateHeight = \old -> do
332 FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
333 , subscriberRecalculateHeight = \new -> do
334 FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
336 when (isJust occ) $ do
337 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
339 let !subscribed = CacheSubscribed
340 { _cacheSubscribed_subscribers = subscribers
341 , _cacheSubscribed_parent = parentSub
342 , _cacheSubscribed_occurrence = occRef
344 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
345 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
346 return subscribedTicket
348 subscribed <- getFastWeakTicketValue subscribedTicket
349 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
350 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
351 let es = EventSubscription
352 { _eventSubscription_unsubscribe = do
353 FastWeakBag.remove ticket
354 isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
356 writeIORef mSubscribedRef emptyFastWeak
357 unsubscribe $ _cacheSubscribed_parent subscribed
359 touch subscribedTicket
360 , _eventSubscription_subscribed = EventSubscribed
361 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
362 , eventSubscribedRetained = toAny subscribedTicket
367subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
368subscribe e s = fst <$> subscribeAndRead e s
371wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
372wrap tag getSpecificSubscribed sub = do
373 (sln, subd, occ) <- getSpecificSubscribed sub
375 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
377eventRoot :: GCompare k => k a -> Root x k -> Event x a
378eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
380eventNever :: Event x a
381eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
383eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
384eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
386eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
387eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
389eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
390eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
392eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
393eventHold !h = Event $ subscribeHoldEvent h
395eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
396eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
398{-# INLINE subscribeCoincidenceInner #-}
399subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)
400subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
401 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
402 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
403 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
404 let height = max innerHeight outerHeight
405 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
406 return (innerOcc, height, innerSubd)
408--------------------------------------------------------------------------------
410--------------------------------------------------------------------------------
412data Subscriber x a = Subscriber
413 { subscriberPropagate :: !(a -> EventM x ())
414 , subscriberInvalidateHeight :: !(Height -> IO ())
415 , subscriberRecalculateHeight :: !(Height -> IO ())
418--TODO: Move this comment to WeakBag
419-- These function are constructor functions that are marked NOINLINE so they are
420-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
421-- so any weak references that are attached to the constructors will have their
422-- finalizer run. Using the opaque constructor, does not see the
423-- constructor application, so it behaves like an IORef and cannot be fused away.
425-- The result is also evaluated to WHNF, since forcing a thunk invalidates
426-- the weak pointer to it in some cases.
428newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
429newSubscriberHold h = return $ Subscriber
430 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
431 , subscriberInvalidateHeight = \_ -> return ()
432 , subscriberRecalculateHeight = \_ -> return ()
435newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
436newSubscriberFan subscribed = return $ Subscriber
437 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
438 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
439 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
440 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
441 scheduleClear $ fanSubscribedOccurrence subscribed
442 let f _ (Pair (Identity v) subsubs) = do
443 propagate v $ _fanSubscribedChildren_list subsubs
445 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
447 , subscriberInvalidateHeight = \old -> do
448 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
449 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
450 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
451 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
452 , subscriberRecalculateHeight = \new -> do
453 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
454 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
455 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
456 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
459newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
460newSubscriberSwitch subscribed = return $ Subscriber
461 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
462 tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
463 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
464 scheduleClear $ switchSubscribedOccurrence subscribed
465 propagate a $ switchSubscribedSubscribers subscribed
466 , subscriberInvalidateHeight = \_ -> do
467 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
468 oldHeight <- readIORef $ switchSubscribedHeight subscribed
469 when (oldHeight /= invalidHeight) $ do
470 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
471 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
472 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
473 , subscriberRecalculateHeight = \new -> do
474 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
475 updateSwitchHeight new subscribed
476 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
479newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
480newSubscriberCoincidenceOuter subscribed = return $ Subscriber
481 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
482 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
483 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
484 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
485 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
486 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
487 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
488 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
489 scheduleClear $ coincidenceSubscribedInnerParent subscribed
492 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
493 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
494 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
495 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
496 Just o -> do -- Since it's already firing, no need to adjust height
497 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
498 scheduleClear $ coincidenceSubscribedOccurrence subscribed
499 propagate o $ coincidenceSubscribedSubscribers subscribed
500 , subscriberInvalidateHeight = \_ -> do
501 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
502 invalidateCoincidenceHeight subscribed
503 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
504 , subscriberRecalculateHeight = \_ -> do
505 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
506 recalculateCoincidenceHeight subscribed
507 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
510newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
511newSubscriberCoincidenceInner subscribed = return $ Subscriber
512 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
513 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
514 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
516 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
518 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
519 scheduleClear $ coincidenceSubscribedOccurrence subscribed
520 propagate a $ coincidenceSubscribedSubscribers subscribed
521 , subscriberInvalidateHeight = \_ -> do
522 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
523 invalidateCoincidenceHeight subscribed
524 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
525 , subscriberRecalculateHeight = \_ -> do
526 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
527 recalculateCoincidenceHeight subscribed
528 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
531invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
532invalidateSubscriberHeight = flip subscriberInvalidateHeight
534recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
535recalculateSubscriberHeight = flip subscriberRecalculateHeight
537-- | Propagate everything at the current height
538propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
539propagate a subscribers = withIncreasedDepth $ do
540 -- 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
541 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
542 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
544-- | Propagate everything at the current height
545propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
546propagateFast a subscribers = withIncreasedDepth $ do
547 -- 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
548 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
549 FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
551--------------------------------------------------------------------------------
553--------------------------------------------------------------------------------
558data EventSubscribed x = EventSubscribed
559 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
560 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
562 , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
563 , eventSubscribedHasOwnHeightRef :: !Bool
564 , eventSubscribedWhoCreated :: !(IO [String])
568eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
569eventSubscribedRoot !r = EventSubscribed
570 { eventSubscribedHeightRef = zeroRef
571 , eventSubscribedRetained = toAny r
573 , eventSubscribedGetParents = return []
574 , eventSubscribedHasOwnHeightRef = False
575 , eventSubscribedWhoCreated = return ["root"]
579eventSubscribedNever :: EventSubscribed x
580eventSubscribedNever = EventSubscribed
581 { eventSubscribedHeightRef = zeroRef
582 , eventSubscribedRetained = toAny ()
584 , eventSubscribedGetParents = return []
585 , eventSubscribedHasOwnHeightRef = False
586 , eventSubscribedWhoCreated = return ["never"]
590eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
591eventSubscribedFan !subscribed = EventSubscribed
592 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
593 , eventSubscribedRetained = toAny subscribed
595 , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
596 , eventSubscribedHasOwnHeightRef = False
597 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
601eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
602eventSubscribedSwitch !subscribed = EventSubscribed
603 { eventSubscribedHeightRef = switchSubscribedHeight subscribed
604 , eventSubscribedRetained = toAny subscribed
606 , eventSubscribedGetParents = do
607 s <- readIORef $ switchSubscribedCurrentParent subscribed
608 return [Some.This $ _eventSubscription_subscribed s]
609 , eventSubscribedHasOwnHeightRef = True
610 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
614eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
615eventSubscribedCoincidence !subscribed = EventSubscribed
616 { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
617 , eventSubscribedRetained = toAny subscribed
619 , eventSubscribedGetParents = do
620 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
621 let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
622 innerParents = maybeToList $ fmap Some.This innerSubscription
623 return $ outerParent : innerParents
624 , eventSubscribedHasOwnHeightRef = True
625 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
629getEventSubscribedHeight :: EventSubscribed x -> IO Height
630getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
633whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
634whoCreatedEventSubscribed = eventSubscribedWhoCreated
636walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
637walkInvalidHeightParents s0 = do
638 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
639 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
640 when (h == invalidHeight) $ do
641 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
642 modify (Some.This s :)
643 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
644 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
648{-# INLINE subscribeHoldEvent #-}
649subscribeHoldEvent :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
650subscribeHoldEvent = subscribeAndRead . holdEvent
652--------------------------------------------------------------------------------
654--------------------------------------------------------------------------------
656newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
658behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
659behaviorHold !h = Behavior $ readHoldTracked h
661behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
662behaviorHoldIdentity = behaviorHold
664behaviorConst :: a -> Behavior x a
665behaviorConst !a = Behavior $ return a
667behaviorPull :: Pull x a -> Behavior x a
668behaviorPull !p = Behavior $ do
669 val <- liftIO $ readIORef $ pullValue p
671 Just subscribed -> do
672 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
673 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
674 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
675 return $ pullSubscribedValue subscribed
677 i <- liftIO $ newInvalidatorPull p
678 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
679 parentsRef <- liftIO $ newIORef []
680 holdInits <- askBehaviorHoldInits
681 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
682 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
683 parents <- liftIO $ readIORef parentsRef
684 let subscribed = PullSubscribed
685 { pullSubscribedValue = a
686 , pullSubscribedInvalidators = invsRef
687 , pullSubscribedOwnInvalidator = i
688 , pullSubscribedParents = parents
690 liftIO $ writeIORef (pullValue p) $ Just subscribed
691 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
694behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
695behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
697{-# INLINE readHoldTracked #-}
698readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
699readHoldTracked h = do
700 result <- liftIO $ readIORef $ holdValue h
701 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
702 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
703 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
706{-# INLINABLE readBehaviorUntracked #-}
707readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
708readBehaviorUntracked b = do
709 holdInits <- getDeferralQueue
710 liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
712--------------------------------------------------------------------------------
714--------------------------------------------------------------------------------
716data Dynamic x p = Dynamic
717 { dynamicCurrent :: !(Behavior x (PatchTarget p))
718 , dynamicUpdated :: !(Event x p)
721dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
722dynamicHold !h = Dynamic
723 { dynamicCurrent = behaviorHold h
724 , dynamicUpdated = eventHold h
727dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
728dynamicHoldIdentity = dynamicHold
730dynamicConst :: PatchTarget p -> Dynamic x p
731dynamicConst !a = Dynamic
732 { dynamicCurrent = behaviorConst a
733 , dynamicUpdated = eventNever
736dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
737dynamicDyn !d = Dynamic
738 { dynamicCurrent = behaviorDyn d
739 , dynamicUpdated = eventDyn d
742dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
743dynamicDynIdentity = dynamicDyn
745--------------------------------------------------------------------------------
747--------------------------------------------------------------------------------
749--TODO: Figure out why certain things are not 'representational', then make them
750--representational so we can use coerce
752--type role Hold representational
754 = Hold { holdValue :: !(IORef (PatchTarget p))
755 , holdInvalidators :: !(IORef [Weak (Invalidator x)])
756 , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
757 , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
763-- | A statically allocated 'SpiderTimeline'; this is the only instance of
764-- 'SpiderTimeline' that can used when using
765-- -fspecialize-to-spidertimeline-global.
768{-# NOINLINE globalSpiderTimelineEnv #-}
769globalSpiderTimelineEnv :: SpiderTimelineEnv Global
770globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
772-- | Stores all global data relevant to a particular Spider timeline; only one
773-- value should exist for each type @x@
774data SpiderTimelineEnv x = SpiderTimelineEnv
775 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
776 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
778 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
781type role SpiderTimelineEnv nominal
783instance Eq (SpiderTimelineEnv x) where
784 _ == _ = True -- Since only one exists of each type
786instance GEq SpiderTimelineEnv where
787#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
789 geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
790 then case unsafeCoerce Refl :: a :~: b of
791 Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
794 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
795 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
800 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
801 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
802 , eventEnvDynInits :: !(IORef [SomeDynInit x])
803 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
804 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
805 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
806 , eventEnvIntClears :: !(IORef [SomeIntClear])
807 , eventEnvRootClears :: !(IORef [SomeRootClear])
808 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
809 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
810 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
813{-# INLINE runEventM #-}
814runEventM :: EventM x a -> IO a
817asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
818asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
820class MonadIO m => Defer a m where
821 getDeferralQueue :: m (IORef [a])
824defer :: Defer a m => a -> m ()
826 q <- getDeferralQueue
827 liftIO $ modifyIORef' q (a:)
829instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
830 {-# INLINE getDeferralQueue #-}
831 getDeferralQueue = asksEventEnv eventEnvAssignments
833instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
834 {-# INLINE getDeferralQueue #-}
835 getDeferralQueue = asksEventEnv eventEnvHoldInits
837instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
838 {-# INLINE getDeferralQueue #-}
839 getDeferralQueue = asksEventEnv eventEnvDynInits
841instance Defer (SomeHoldInit x) (BehaviorM x) where
842 {-# INLINE getDeferralQueue #-}
843 getDeferralQueue = BehaviorM $ asks snd
845instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
846 {-# INLINE getDeferralQueue #-}
847 getDeferralQueue = asksEventEnv eventEnvMergeUpdates
849instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
850 {-# INLINE getDeferralQueue #-}
851 getDeferralQueue = asksEventEnv eventEnvMergeInits
853class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
854 getCurrentHeight :: m Height
855 scheduleMerge :: Height -> EventM x () -> m ()
857instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
858 {-# INLINE getCurrentHeight #-}
859 getCurrentHeight = do
860 heightRef <- asksEventEnv eventEnvCurrentHeight
861 liftIO $ readIORef heightRef
862 {-# INLINE scheduleMerge #-}
863 scheduleMerge height subscribed = do
864 delayedRef <- asksEventEnv eventEnvDelayedMerges
865 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
867#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
868class x ~ Global => HasSpiderTimeline x where
870class HasSpiderTimeline x where
872 -- | Retrieve the current SpiderTimelineEnv
873 spiderTimeline :: SpiderTimelineEnv x
875instance HasSpiderTimeline Global where
876 spiderTimeline = globalSpiderTimelineEnv
878putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
879putCurrentHeight h = do
880 heightRef <- asksEventEnv eventEnvCurrentHeight
881 liftIO $ writeIORef heightRef $! h
883instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
884 {-# INLINE getDeferralQueue #-}
885 getDeferralQueue = asksEventEnv eventEnvClears
887{-# INLINE scheduleClear #-}
888scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
889scheduleClear r = defer $ SomeClear r
891instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
892 {-# INLINE getDeferralQueue #-}
893 getDeferralQueue = asksEventEnv eventEnvIntClears
895{-# INLINE scheduleIntClear #-}
896scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
897scheduleIntClear r = defer $ SomeIntClear r
899instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
900 {-# INLINE getDeferralQueue #-}
901 getDeferralQueue = asksEventEnv eventEnvRootClears
903{-# INLINE scheduleRootClear #-}
904scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
905scheduleRootClear r = defer $ SomeRootClear r
907instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
908 {-# INLINE getDeferralQueue #-}
909 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
911-- Note: hold cannot examine its event until after the phase is over
912{-# INLINE [1] hold #-}
913hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
915 valRef <- liftIO $ newIORef v0
916 invsRef <- liftIO $ newIORef []
917 parentRef <- liftIO $ newIORef Nothing
919 nodeId <- liftIO newNodeId
923 , holdInvalidators = invsRef
925 , holdParent = parentRef
927 , holdNodeId = nodeId
930 defer $ SomeHoldInit h
933{-# INLINE getHoldEventSubscription #-}
934getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
935getHoldEventSubscription h = do
936 ep <- liftIO $ readIORef $ holdParent h
938 Just subd -> return subd
941 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
942 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
943 liftIO $ writeIORef subscriptionRef $! subscription
947 old <- liftIO $ readIORef $ holdValue h
951 -- Need to evaluate these so that we don't retain the Hold itself
952 v <- liftIO $ evaluate $ holdValue h
953 i <- liftIO $ evaluate $ holdInvalidators h
954 defer $ SomeAssignment v i new
955 liftIO $ writeIORef (holdParent h) $ Just subscription
958type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
960--type role BehaviorM representational
961-- BehaviorM can sample behaviors
962newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
964instance Monad (BehaviorM x) where
966 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
968 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
969 {-# INLINE return #-}
970 return x = BehaviorM $ return x
972 fail s = BehaviorM $ fail s
974data BehaviorSubscribed x a
975 = forall p. BehaviorSubscribedHold (Hold x p)
976 | BehaviorSubscribedPull (PullSubscribed x a)
978data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
980--type role PullSubscribed representational
981data PullSubscribed x a
982 = PullSubscribed { pullSubscribedValue :: !a
983 , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
984 , pullSubscribedOwnInvalidator :: !(Invalidator x)
985 , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
988--type role Pull representational
990 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
991 , pullCompute :: !(BehaviorM x a)
998 = forall a. InvalidatorPull (Pull x a)
999 | forall a. InvalidatorSwitch (SwitchSubscribed x a)
1001data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1002 { rootSubscribedKey :: !(k a)
1003 , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
1004 , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1005 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
1006 , rootSubscribedUninit :: IO ()
1007 , 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?
1009 , rootSubscribedNodeId :: Int
1013data Root x (k :: * -> *)
1014 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1015 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1016 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1019data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1021data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1023data SomeMergeUpdate x = SomeMergeUpdate
1024 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1025 , _someMergeUpdate_invalidateHeight :: !(IO ())
1026 , _someMergeUpdate_recalculateHeight :: !(IO ())
1029newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1031-- EventM can do everything BehaviorM can, plus create holds
1032newtype 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
1034newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1036data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1037 { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1038 , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1041data HeightBag = HeightBag
1042 { _heightBag_size :: {-# UNPACK #-} !Int
1043 , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1045 deriving (Show, Read, Eq, Ord)
1047heightBagEmpty :: HeightBag
1048heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1050heightBagSize :: HeightBag -> Int
1051heightBagSize = _heightBag_size
1053heightBagFromList :: [Height] -> HeightBag
1054heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1056heightBagAdd :: Height -> HeightBag -> HeightBag
1057heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1059heightBagRemove :: Height -> HeightBag -> HeightBag
1060heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1061 Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1062 Just old -> HeightBag (pred s) $ case old of
1063 0 -> IntMap.delete h c
1064 _ -> IntMap.insert h (pred old) c
1066heightBagMax :: HeightBag -> Height
1067heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1068 Just ((h, _), _) -> Height h
1069 Nothing -> zeroHeight
1071heightBagVerify :: HeightBag -> HeightBag
1073heightBagVerify b@(HeightBag s c) = if
1074 | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1075 -> error $ "heightBagVerify: size doesn't match: " <> show b
1076 | unHeight invalidHeight `IntMap.member` c
1077 -> error $ "heightBagVerify: contains invalid height: " <> show b
1083data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1084 { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1085 , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1086 , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1089data FanSubscribed (x :: *) k
1090 = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1091 , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1092 , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1093 , fanSubscribedParent :: !(EventSubscription x)
1095 , fanSubscribedNodeId :: Int
1100 = Fan { fanParent :: !(Event x (DMap k Identity))
1101 , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1104data SwitchSubscribed x a
1105 = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1106 , switchSubscribedOccurrence :: !(IORef (Maybe a))
1107 , switchSubscribedHeight :: !(IORef Height)
1108 , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1109 , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1110 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1111 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1112 , switchSubscribedParent :: !(Behavior x (Event x a))
1113 , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1114 , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1116 , switchSubscribedNodeId :: Int
1121 = Switch { switchParent :: !(Behavior x (Event x a))
1122 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1125#ifdef USE_TEMPLATE_HASKELL
1126{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1128data CoincidenceSubscribed x a
1129 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1130 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1131 , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1132 , coincidenceSubscribedHeight :: !(IORef Height)
1133 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1134 , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1135 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1136 , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1138 , coincidenceSubscribedNodeId :: Int
1143 = Coincidence { coincidenceParent :: !(Event x (Event x a))
1144 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1147{-# NOINLINE newInvalidatorSwitch #-}
1148newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1149newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1151{-# NOINLINE newInvalidatorPull #-}
1152newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1153newInvalidatorPull p = return $! InvalidatorPull p
1155instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1156 fmapMaybe f = push $ return . f
1158instance HasSpiderTimeline x => Align (Event x) where
1160 align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1162newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1164newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1165newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1167--TODO: Avoid the duplication between this and R.zipDynWith
1168zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1170 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1171 ec = flip push eab $ \o -> do
1173 This (Identity a) -> do
1174 b <- readBehaviorUntracked $ dynamicCurrent db
1176 That (Identity b) -> do
1177 a <- readBehaviorUntracked $ dynamicCurrent da
1179 These (Identity a) (Identity b) -> return (a, b)
1180 return $ Just $ Identity $ f a b
1181 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1183buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1184buildDynamic readV0 v' = do
1185 result <- liftIO $ newIORef $ Left (readV0, v')
1187 defer $ SomeDynInit d
1190unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1191unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1192 where x = (readV0, v')
1194-- ResultM can read behaviors and events
1195type ResultM = EventM
1197{-# NOINLINE unsafeNewIORef #-}
1198unsafeNewIORef :: a -> b -> IORef b
1199unsafeNewIORef a b = unsafePerformIO $ do
1203instance HasSpiderTimeline x => Functor (Event x) where
1204 fmap f = push $ return . Just . f
1206instance Functor (Behavior x) where
1207 fmap f = pull . fmap f . readBehaviorTracked
1210push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1211push f e = cacheEvent (pushCheap f e)
1213{-# INLINABLE pull #-}
1214pull :: BehaviorM x a -> Behavior x a
1215pull a = behaviorPull $ Pull
1217 , pullValue = unsafeNewIORef a Nothing
1219 , pullNodeId = unsafeNodeId a
1223{-# INLINABLE switch #-}
1224switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1225switch a = eventSwitch $ Switch
1227 , switchSubscribed = unsafeNewIORef a Nothing
1230coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1231coincidence a = eventCoincidence $ Coincidence
1232 { coincidenceParent = a
1233 , coincidenceSubscribed = unsafeNewIORef a Nothing
1236-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1237run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1239 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1241 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1242 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1243 occBefore <- liftIO $ do
1244 occBefore <- readIORef occRef
1245 writeIORef occRef $! DMap.insert k a occBefore
1247 if DMap.null occBefore
1248 then do scheduleRootClear occRef
1251 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1252 propagate a subscribersRef
1253 delayedRef <- asksEventEnv eventEnvDelayedMerges
1255 delayed <- liftIO $ readIORef delayedRef
1256 case IntMap.minViewWithKey delayed of
1257 Nothing -> return ()
1258 Just ((currentHeight, cur), future) -> do
1259 tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1260 putCurrentHeight $ Height currentHeight
1261 liftIO $ writeIORef delayedRef $! future
1265 putCurrentHeight maxBound
1267 tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1270scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1271scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1272 height <- liftIO $ readIORef heightRef
1273 currentHeight <- getCurrentHeight
1274 case height `compare` currentHeight of
1275 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1276 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1279data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1281data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1283data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1285data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1287debugFinalize :: Bool
1288debugFinalize = False
1290mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1291mkWeakPtrWithDebug x debugNote = do
1295 then Just $ putStrLn $ "finalizing: " ++ debugNote
1298type WeakList a = [Weak a]
1300{-# INLINE withIncreasedDepth #-}
1302withIncreasedDepth :: CanTrace x m => m a -> m a
1303withIncreasedDepth a = do
1304 spiderTimeline <- askSpiderTimelineEnv
1305 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1307 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1310withIncreasedDepth :: m a -> m a
1311withIncreasedDepth = id
1314type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1316{-# INLINE tracePropagate #-}
1317tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1318tracePropagate p = traceWhen p debugPropagate
1320{-# INLINE traceInvalidate #-}
1321traceInvalidate :: String -> IO ()
1322traceInvalidate = when debugInvalidate . liftIO . putStrLn
1324{-# INLINE traceWhen #-}
1325traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1326traceWhen p b message = traceMWhen p b $ return message
1328{-# INLINE traceMWhen #-}
1329traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1330traceMWhen _ b getMessage = when b $ do
1331 message <- getMessage
1333 spiderTimeline <- askSpiderTimelineEnv
1334 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1338 liftIO $ putStrLn $ replicate d ' ' <> message
1340whoCreatedIORef :: IORef a -> IO [String]
1341whoCreatedIORef (IORef a) = whoCreated $! a
1344groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1347 (x :| xs) : t -> case groupByHead t of
1348 [] -> [(x, xs :| [])]
1350 | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1351 | otherwise -> (x, xs :| []) : l
1353listsToForest :: Eq a => [[a]] -> Forest a
1354listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1357{-# INLINE propagateSubscriberHold #-}
1358propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1359propagateSubscriberHold h a = do
1360 {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1361 invalidators <- liftIO $ readIORef $ holdInvalidators h
1362 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1363 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1364 case {-# SCC "apply" #-} apply a v of
1365 Nothing -> return ()
1367 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1368 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1369 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1370 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1372data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1374runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1375runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1377askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1379 (!m, _) <- BehaviorM ask
1381 Nothing -> return Nothing
1382 Just (!wi, _) -> return $ Just wi
1384askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1386 (!m, _) <- BehaviorM ask
1388 Nothing -> return Nothing
1389 Just (_, !p) -> return $ Just p
1391askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1392askBehaviorHoldInits = do
1393 (_, !his) <- BehaviorM ask
1396{-# INLINE getDynHold #-}
1397getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1399 mh <- liftIO $ readIORef $ unDyn d
1402 Left (readV0, v') -> do
1403 holdInits <- getDeferralQueue
1404 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1406 liftIO $ writeIORef (unDyn d) $ Right h
1409-- Always refers to 0
1410{-# NOINLINE zeroRef #-}
1411zeroRef :: IORef Height
1412zeroRef = unsafePerformIO $ newIORef zeroHeight
1414getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1415getRootSubscribed k r sub = do
1416 mSubscribed <- readIORef $ rootSubscribed r
1417 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1418 case DMap.lookup k mSubscribed of
1419 Just subscribed -> {-# SCC "hitRoot" #-} do
1420 sln <- subscribeRootSubscribed subscribed sub
1422 return (sln, subscribed, occ)
1423 Nothing -> {-# SCC "missRoot" #-} do
1424 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1425 let !cached = rootSubscribed r
1426 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1427 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1428 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1429 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1430 writeIORef uninitRef $! uninit
1431 let !subscribed = RootSubscribed
1432 { rootSubscribedKey = k
1433 , rootSubscribedCachedSubscribed = cached
1434 , rootSubscribedOccurrence = getOcc
1435 , rootSubscribedSubscribers = subs
1436 , rootSubscribedUninit = uninit
1437 , rootSubscribedWeakSelf = weakSelf
1439 , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1442 -- If we die at the same moment that all our children die, they will
1443 -- try to clean us up but will fail because their Weak reference to us
1444 -- will also be dead. So, if we are dying, check if there are any
1445 -- children; since children don't bother cleaning themselves up if
1446 -- their parents are already dead, I don't think there's a race
1447 -- condition here. However, if there are any children, then we can
1448 -- infer that we need to clean ourselves up, so we do.
1450 cs <- readIORef $ _weakBag_children subs
1451 when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1452 writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1453 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
1455 return (sln, subscribed, occ)
1457#ifdef USE_TEMPLATE_HASKELL
1458{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1460cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1461cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1462 rootSubscribedUninit self
1463 modifyIORef' cached $ DMap.delete k
1465{-# INLINE subscribeRootSubscribed #-}
1466subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1467subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1469newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1471data FanInt x a = FanInt
1472 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1473 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1474 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1477newFanInt :: IO (FanInt x a)
1479 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
1480 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1481 occRef <- newIORef $ error "fanInt: no occurrence"
1483 { _fanInt_subscribers = subscribers
1484 , _fanInt_subscriptionRef = subscriptionRef
1485 , _fanInt_occRef = occRef
1488{-# NOINLINE unsafeNewFanInt #-}
1489unsafeNewFanInt :: b -> FanInt x a
1490unsafeNewFanInt b = unsafePerformIO $ do
1494fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1496 let self = unsafeNewFanInt p
1497 in EventSelectorInt $ \k -> Event $ \sub -> do
1498 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1499 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1500 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1501 { subscriberPropagate = \m -> do
1502 liftIO $ writeIORef (_fanInt_occRef self) m
1503 scheduleIntClear $ _fanInt_occRef self
1504 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1505 FastWeakBag.traverse b $ \s -> do
1506 subscriberPropagate s v
1507 , subscriberInvalidateHeight = \old -> do
1508 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1509 FastWeakBag.traverse b $ \s -> do
1510 subscriberInvalidateHeight s old
1511 , subscriberRecalculateHeight = \new -> do
1512 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1513 FastWeakBag.traverse b $ \s -> do
1514 subscriberRecalculateHeight s new
1517 writeIORef (_fanInt_subscriptionRef self) subscription
1518 writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1519 scheduleIntClear $ _fanInt_occRef self
1521 b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1523 b <- FastWeakBag.empty
1524 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1527 t <- liftIO $ FastWeakBag.insert sub b
1528 currentOcc <- readIORef (_fanInt_occRef self)
1529 (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1530 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1532{-# INLINABLE getFanSubscribed #-}
1533getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1534getFanSubscribed k f sub = do
1535 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1537 Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1538 sln <- subscribeFanSubscribed k subscribed sub
1539 occ <- readIORef $ fanSubscribedOccurrence subscribed
1540 return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1541 Nothing -> {-# SCC "missFan" #-} do
1542 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1543 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1544 s <- liftIO $ newSubscriberFan subscribedUnsafe
1545 (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1546 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1547 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1548 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1549 occRef <- liftIO $ newIORef parentOcc
1550 when (isJust parentOcc) $ scheduleClear occRef
1551 let subscribed = FanSubscribed
1552 { fanSubscribedCachedSubscribed = fanSubscribed f
1553 , fanSubscribedOccurrence = occRef
1554 , fanSubscribedParent = subscription
1555 , fanSubscribedSubscribers = subscribersRef
1557 , fanSubscribedNodeId = unsafeNodeId f
1560 let !self = (k, subscribed)
1561 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1562 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1563 liftIO $ writeIORef subscribedRef $! subscribed
1564 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1565 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1567cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1568cleanupFanSubscribed (k, subscribed) = do
1569 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1570 let reducedSubscribers = DMap.delete k subscribers
1571 if DMap.null reducedSubscribers
1573 unsubscribe $ fanSubscribedParent subscribed
1574 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1575 writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1576 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1578{-# INLINE subscribeFanSubscribed #-}
1579subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1580subscribeFanSubscribed k subscribed sub = do
1581 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1582 case DMap.lookup k subscribers of
1583 Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1584 let !self = (k, subscribed)
1585 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1586 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1587 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
1589 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1591{-# INLINABLE getSwitchSubscribed #-}
1592getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1593getSwitchSubscribed s sub = do
1594 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1596 Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1597 sln <- subscribeSwitchSubscribed subscribed sub
1598 occ <- readIORef $ switchSubscribedOccurrence subscribed
1599 return (sln, subscribed, occ)
1600 Nothing -> {-# SCC "missSwitch" #-} do
1601 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1602 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1603 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1604 mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1605 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1606 wiRef <- liftIO $ newIORef wi
1607 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1608 holdInits <- getDeferralQueue
1609 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1610 (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1611 heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1612 subscriptionRef <- liftIO $ newIORef subscription
1613 occRef <- liftIO $ newIORef parentOcc
1614 when (isJust parentOcc) $ scheduleClear occRef
1615 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1616 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1617 let !subscribed = SwitchSubscribed
1618 { switchSubscribedCachedSubscribed = switchSubscribed s
1619 , switchSubscribedOccurrence = occRef
1620 , switchSubscribedHeight = heightRef
1621 , switchSubscribedSubscribers = subs
1622 , switchSubscribedOwnInvalidator = i
1623 , switchSubscribedOwnWeakInvalidator = wiRef
1624 , switchSubscribedBehaviorParents = parentsRef
1625 , switchSubscribedParent = switchParent s
1626 , switchSubscribedCurrentParent = subscriptionRef
1627 , switchSubscribedWeakSelf = weakSelf
1629 , switchSubscribedNodeId = unsafeNodeId s
1632 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1633 liftIO $ writeIORef subscribedRef $! subscribed
1634 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1635 return (slnForSub, subscribed, parentOcc)
1637cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1638cleanupSwitchSubscribed subscribed = do
1639 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1640 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1641 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1643{-# INLINE subscribeSwitchSubscribed #-}
1644subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1645subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1647{-# INLINABLE getCoincidenceSubscribed #-}
1648getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1649getCoincidenceSubscribed c sub = do
1650 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1652 Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1653 sln <- subscribeCoincidenceSubscribed subscribed sub
1654 occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1655 return (sln, subscribed, occ)
1656 Nothing -> {-# SCC "missCoincidence" #-} do
1657 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1658 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1659 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1660 (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1661 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1662 (occ, height, mInnerSubd) <- case outerOcc of
1663 Nothing -> return (Nothing, outerHeight, Nothing)
1665 (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1666 return (occ, height, Just innerSubd)
1667 occRef <- liftIO $ newIORef occ
1668 when (isJust occ) $ scheduleClear occRef
1669 heightRef <- liftIO $ newIORef height
1670 innerSubdRef <- liftIO $ newIORef mInnerSubd
1671 scheduleClear innerSubdRef
1672 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1673 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1674 let subscribed = CoincidenceSubscribed
1675 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1676 , coincidenceSubscribedOccurrence = occRef
1677 , coincidenceSubscribedHeight = heightRef
1678 , coincidenceSubscribedSubscribers = subs
1679 , coincidenceSubscribedOuter = subOuter
1680 , coincidenceSubscribedOuterParent = outerSubscription
1681 , coincidenceSubscribedInnerParent = innerSubdRef
1682 , coincidenceSubscribedWeakSelf = weakSelf
1684 , coincidenceSubscribedNodeId = unsafeNodeId c
1687 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1688 liftIO $ writeIORef subscribedRef $! subscribed
1689 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1690 return (slnForSub, subscribed, occ)
1692cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1693cleanupCoincidenceSubscribed subscribed = do
1694 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1695 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1697{-# INLINE subscribeCoincidenceSubscribed #-}
1698subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1699subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1702merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1703merge d = cacheEvent (mergeCheap d)
1705{-# INLINE mergeWithMove #-}
1706mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1707mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1709{-# INLINE [1] mergeCheap #-}
1710mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1711mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1713 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1714 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1715 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1716 (mOldSubd, newPs) <- case me of
1717 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1719 let s = subscriber $ return k
1720 subscription@(EventSubscription _ subd) <- subscribe e s
1721 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1722 let newParent = MergeSubscribedParent subscription
1723 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1724 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1725 forM_ mOldSubd $ \oldSubd -> do
1726 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1727 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1728 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1729 foldM f ([], oldParents) $ DMap.toList p
1730 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1731 getInitialSubscribers initialParents subscriber = do
1732 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1733 let s = subscriber $ return k
1734 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1735 height <- liftIO $ getEventSubscribedHeight parentSubd
1736 return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1737 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1738 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1739 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1741 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1742 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1744{-# INLINE [1] mergeCheapWithMove #-}
1745mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1746mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1748 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1749 updateMe subscriber heightBagRef oldParents p = do
1750 -- Prepare new parents for insertion
1751 let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1752 subscribeParent k e = do
1753 keyRef <- liftIO $ newIORef k
1754 let s = subscriber $ liftIO $ readIORef keyRef
1755 subscription@(EventSubscription _ subd) <- subscribe e s
1757 newParentHeight <- getEventSubscribedHeight subd
1758 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1759 return $ MergeSubscribedParentWithMove subscription keyRef
1760 p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1761 -- Collect old parents for deletion and update the keys of moved parents
1762 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1763 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1765 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1766 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1767 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1769 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1771 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1772 return (toDelete, applyAlways p' oldParents)
1773 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1774 getInitialSubscribers initialParents subscriber = do
1775 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1776 keyRef <- liftIO $ newIORef k
1777 let s = subscriber $ liftIO $ readIORef keyRef
1778 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1779 height <- liftIO $ getEventSubscribedHeight parentSubd
1780 return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1781 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1782 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1783 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1785 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1786 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1788type MergeUpdateFunc k x p s
1789 = (forall a. EventM x (k a) -> Subscriber x a)
1793 -> EventM x ([EventSubscription x], DMap k s)
1795type MergeInitFunc k x s
1797 -> (forall a. EventM x (k a) -> Subscriber x a)
1798 -> EventM x (DMap k Identity, [Height], DMap k s)
1800type MergeDestroyFunc k s
1804data Merge x k s = Merge
1805 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1806 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1807 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1808 , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1809 , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1812invalidateMergeHeight :: Merge x k s -> IO ()
1813invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1815invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1816invalidateMergeHeight' heightRef sub = do
1817 oldHeight <- readIORef heightRef
1818 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
1819 writeIORef heightRef $! invalidHeight
1820 subscriberInvalidateHeight sub oldHeight
1823revalidateMergeHeight :: Merge x k s -> IO ()
1824revalidateMergeHeight m = do
1825 currentHeight <- readIORef $ _merge_heightRef m
1826 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1827 heights <- readIORef $ _merge_heightBagRef m
1828 parents <- readIORef $ _merge_parentsRef m
1829 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1830 case heightBagSize heights `compare` DMap.size parents of
1833 let height = succHeight $ heightBagMax heights
1834 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1835 writeIORef (_merge_heightRef m) $! height
1836 subscriberRecalculateHeight (_merge_sub m) height
1837 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1839scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1840scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1841 vals <- liftIO $ readIORef $ _merge_accumRef m
1842 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1843 --TODO: Assert that m is not empty
1844 subscriberPropagate (_merge_sub m) vals
1846mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1847mergeSubscriber m getKey = Subscriber
1848 { subscriberPropagate = \a -> do
1849 oldM <- liftIO $ readIORef $ _merge_accumRef m
1851 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1852 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1853 liftIO $ writeIORef (_merge_accumRef m) $! newM
1854 when (DMap.null oldM) $ do -- Only schedule the firing once
1855 height <- liftIO $ readIORef $ _merge_heightRef m
1856 --TODO: assertions about height
1857 currentHeight <- getCurrentHeight
1858 when (height <= currentHeight) $ do
1859 if height /= invalidHeight
1861 myStack <- liftIO $ whoCreatedIORef undefined --TODO
1862 error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1865 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1866 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1867 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1871 error $ "Causality loop found" <> cycleInfo
1872 scheduleMergeSelf m height
1873 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1874 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1875 invalidateMergeHeight m
1876 , subscriberRecalculateHeight = \new -> do
1877 modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1878 revalidateMergeHeight m
1881--TODO: Be able to run as much of this as possible promptly
1882updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1883updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1885 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1886 (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1887 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1888 return subscriptionsToKill
1890{-# INLINE mergeCheap' #-}
1891mergeCheap' :: 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 -> Dynamic x p -> Event x (DMap k Identity)
1892mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1893 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1894 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1895 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1896 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1897 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1899 { _merge_parentsRef = parentsRef
1900 , _merge_heightBagRef = heightBagRef
1901 , _merge_heightRef = heightRef
1903 , _merge_accumRef = accumRef
1905 (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1906 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1907 myHeight = if invalidHeight `elem` heights
1909 else succHeight $ heightBagMax myHeightBag
1910 currentHeight <- getCurrentHeight
1911 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1912 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1914 unless (DMap.null accum) $ do
1915 scheduleMergeSelf m myHeight
1916 liftIO $ writeIORef accumRef $! accum
1917 liftIO $ writeIORef heightRef $! myHeight
1918 liftIO $ writeIORef heightBagRef $! myHeightBag
1919 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1920 liftIO $ writeIORef parentsRef $! initialParentState
1921 defer $ SomeMergeInit $ do
1923 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1924 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1925 defer $ updateMerge m updateFunc a
1926 , subscriberInvalidateHeight = \_ -> return ()
1927 , subscriberRecalculateHeight = \_ -> return ()
1929 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1930 forM_ change $ \c -> defer $ updateMerge m updateFunc c
1931 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1932 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1933 -- its subscription.
1934 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1935 let unsubscribeAll = destroy =<< readIORef parentsRef
1936 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1940mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1941mergeInt = cacheEvent . mergeIntCheap
1943{-# INLINABLE mergeIntCheap #-}
1944mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1945mergeIntCheap d = Event $ \sub -> do
1946 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1947 accum <- liftIO $ FastMutableIntMap.newEmpty
1948 heightRef <- liftIO $ newIORef zeroHeight
1949 heightBagRef <- liftIO $ newIORef heightBagEmpty
1950 parents <- liftIO $ FastMutableIntMap.newEmpty
1951 let scheduleSelf = do
1952 height <- liftIO $ readIORef $ heightRef
1953 scheduleMerge' height heightRef $ do
1954 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1955 subscriberPropagate sub vals
1956 invalidateMyHeight = do
1957 invalidateMergeHeight' heightRef sub
1958 recalculateMyHeight = do
1959 currentHeight <- readIORef heightRef
1960 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?
1961 heights <- readIORef heightBagRef
1962 numParents <- FastMutableIntMap.size parents
1963 case heightBagSize heights `compare` numParents of
1966 let height = succHeight $ heightBagMax heights
1967 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1968 writeIORef heightRef $! height
1969 subscriberRecalculateHeight sub height
1970 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1971 mySubscriber k = Subscriber
1972 { subscriberPropagate = \a -> do
1973 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1974 liftIO $ FastMutableIntMap.insert accum k a
1975 when wasEmpty scheduleSelf
1976 , subscriberInvalidateHeight = \old -> do
1977 modifyIORef' heightBagRef $ heightBagRemove old
1979 , subscriberRecalculateHeight = \new -> do
1980 modifyIORef' heightBagRef $ heightBagAdd new
1983 forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1984 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1986 forM_ parentOcc $ FastMutableIntMap.insert accum k
1987 FastMutableIntMap.insert parents k subscription
1988 height <- getEventSubscribedHeight parentSubd
1989 if height == invalidHeight
1990 then writeIORef heightRef invalidHeight
1992 modifyIORef' heightBagRef $ heightBagAdd height
1993 modifyIORef' heightRef $ \oldHeight ->
1994 if oldHeight == invalidHeight
1996 else max (succHeight height) oldHeight
1997 myHeight <- liftIO $ readIORef heightRef
1998 currentHeight <- getCurrentHeight
1999 isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2000 occ <- if currentHeight >= myHeight -- If we should have fired by now
2003 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2004 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2006 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2007 defer $ SomeMergeInit $ do
2008 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2011 let f k newParent = do
2012 subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
2013 newParentHeight <- liftIO $ getEventSubscribedHeight subd
2014 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
2016 newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
2017 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2018 liftIO $ for_ oldParents $ \oldParent -> do
2019 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2020 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2021 return $ IntMap.elems oldParents
2023 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2024 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2026 , subscriberInvalidateHeight = \_ -> return ()
2027 , subscriberRecalculateHeight = \_ -> return ()
2029 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2030 forM_ change $ \c -> defer $ updateMe c
2031 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2032 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2033 -- its subscription.
2034 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2035 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2036 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2040newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2042fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2046 , fanSubscribed = unsafeNewIORef e Nothing
2048 in EventSelector $ \k -> eventFan k f
2050runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2051runHoldInits holdInitRef dynInitRef mergeInitRef = do
2052 holdInits <- liftIO $ readIORef holdInitRef
2053 dynInits <- liftIO $ readIORef dynInitRef
2054 mergeInits <- liftIO $ readIORef mergeInitRef
2055 unless (null holdInits && null dynInits && null mergeInits) $ do
2056 liftIO $ writeIORef holdInitRef []
2057 liftIO $ writeIORef dynInitRef []
2058 liftIO $ writeIORef mergeInitRef []
2059 mapM_ initHold holdInits
2060 mapM_ initDyn dynInits
2061 mapM_ unSomeMergeInit mergeInits
2062 runHoldInits holdInitRef dynInitRef mergeInitRef
2064initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2065initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2067initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2068initDyn (SomeDynInit d) = void $ getDynHold d
2070newEventEnv :: IO (EventEnv x)
2072 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2073 holdInitRef <- newIORef []
2074 dynInitRef <- newIORef []
2075 mergeUpdateRef <- newIORef []
2076 mergeInitRef <- newIORef []
2077 heightRef <- newIORef zeroHeight
2078 toClearRef <- newIORef []
2079 toClearIntRef <- newIORef []
2080 toClearRootRef <- newIORef []
2081 coincidenceInfosRef <- newIORef []
2082 delayedRef <- newIORef IntMap.empty
2083 return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2085clearEventEnv :: EventEnv x -> IO ()
2086clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2087 writeIORef toAssignRef []
2088 writeIORef holdInitRef []
2089 writeIORef dynInitRef []
2090 writeIORef mergeUpdateRef []
2091 writeIORef mergeInitRef []
2092 writeIORef heightRef zeroHeight
2093 writeIORef toClearRef []
2094 writeIORef toClearIntRef []
2095 writeIORef toClearRootRef []
2096 writeIORef coincidenceInfosRef []
2097 writeIORef delayedRef IntMap.empty
2099-- | Run an event action outside of a frame
2100runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2101runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2102 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2105 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
2107 result <- runEventM go
2108 toClear <- readIORef $ eventEnvClears env
2109 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2110 toClearInt <- readIORef $ eventEnvIntClears env
2111 forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2112 toClearRoot <- readIORef $ eventEnvRootClears env
2113 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2114 toAssign <- readIORef $ eventEnvAssignments env
2115 toReconnectRef <- newIORef []
2116 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2117 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2119 when debugInvalidate $ putStrLn $ "Invalidating Hold"
2120 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2121 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2122 writeIORef (eventEnvMergeUpdates env) []
2123 when debugPropagate $ putStrLn "Updating merges"
2124 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2125 when debugPropagate $ putStrLn "Updating merges done"
2126 toReconnect <- readIORef toReconnectRef
2128 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2129 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2130 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2131 when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2133 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2134 wi' <- mkWeakPtrWithDebug i "wi'"
2135 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2136 writeIORef (switchSubscribedBehaviorParents subscribed) []
2137 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2138 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2139 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
2140 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2141 sub <- newSubscriberSwitch subscribed
2142 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
2144 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2145 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2146 EventRoot _ -> "EventRoot"
2147 EventNever -> "EventNever"
2148 _ -> "something else"
2150 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2151 return oldSubscription
2152 liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2153 liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2154 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2155 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2156 parentHeight <- getEventSubscribedHeight subd'
2157 myHeight <- readIORef $ switchSubscribedHeight subscribed
2158 when (parentHeight /= myHeight) $ do
2159 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2160 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2161 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
2162 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2163 unsubscribe subscription
2164 mapM_ invalidateCoincidenceHeight mcs
2165 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2166 mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2167 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2168 height <- calculateSwitchHeight subscribed
2169 updateSwitchHeight height subscribed
2172newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2174{-# INLINE zeroHeight #-}
2176zeroHeight = Height 0
2178{-# INLINE invalidHeight #-}
2179invalidHeight :: Height
2180invalidHeight = Height (-1000)
2183-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2184{-# INLINE invalidHeightBeingTraversed #-}
2185invalidHeightBeingTraversed :: Height
2186invalidHeightBeingTraversed = Height (-1001)
2189{-# INLINE succHeight #-}
2190succHeight :: Height -> Height
2191succHeight h@(Height a) =
2192 if h == invalidHeight
2194 else Height $ succ a
2196invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2197invalidateCoincidenceHeight subscribed = do
2198 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2199 when (oldHeight /= invalidHeight) $ do
2200 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2201 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2203updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2204updateSwitchHeight new subscribed = do
2205 oldHeight <- readIORef $ switchSubscribedHeight subscribed
2206 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2207 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2208 writeIORef (switchSubscribedHeight subscribed) $! new
2209 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2211recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2212recalculateCoincidenceHeight subscribed = do
2213 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2214 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2215 height <- calculateCoincidenceHeight subscribed
2216 when (height /= invalidHeight) $ do
2217 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2218 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2220calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2221calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2223calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2224calculateCoincidenceHeight subscribed = do
2225 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2226 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2227 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2229data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2231invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2232invalidate toReconnectRef wis = do
2233 forM_ wis $ \wi -> do
2237 traceInvalidate "invalidate Dead"
2238 return () --TODO: Should we clean this up here?
2240 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2242 InvalidatorPull p -> do
2243 traceInvalidate $ "invalidate: Pull" <> showNodeId p
2244 mVal <- readIORef $ pullValue p
2245 forM_ mVal $ \val -> do
2246 writeIORef (pullValue p) Nothing
2247 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2248 InvalidatorSwitch subscribed -> do
2249 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2250 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2251 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
2253--------------------------------------------------------------------------------
2254-- Reflex integration
2255--------------------------------------------------------------------------------
2257#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2258-- When we're specializing, we include this from Reflex.Class instead, because
2259-- it needs access to these types; when we're not, we want them here, so our
2260-- instance isn't an orphan instance.
2261#include "SpiderTimeline.include.hs"
2262#include "SpiderTimelineHost.include.hs"
2265unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2266unsafeNewSpiderTimelineEnv = do
2270 depthRef <- newIORef 0
2272 return $ SpiderTimelineEnv
2273 { _spiderTimeline_lock = lock
2274 , _spiderTimeline_eventEnv = env
2276 , _spiderTimeline_depth = depthRef
2280#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2281-- | Create a new SpiderTimelineEnv
2282newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2283newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2285data LocalSpiderTimeline x s
2287instance Reifies s (SpiderTimelineEnv x) =>
2288 HasSpiderTimeline (LocalSpiderTimeline x s) where
2289 spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2293 -> SpiderTimelineEnv x
2294 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2295localSpiderTimeline _ = unsafeCoerce
2297-- | Pass a new timeline to the given function.
2298withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2299withSpiderTimeline k = do
2300 env <- unsafeNewSpiderTimelineEnv
2301 reify env $ \s -> k $ localSpiderTimeline s env
2304newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2306type ComputeM = EventM
2308newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2310#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2311instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2312 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2313 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2314 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2315 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2316 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2317 type PullM (SpiderTimeline x) = SpiderPullM x
2318 type PushM (SpiderTimeline x) = SpiderPushM x
2319 {-# INLINABLE never #-}
2320 never = SpiderEvent eventNever
2321 {-# INLINABLE constant #-}
2322 constant = SpiderBehavior . behaviorConst
2324 push f = SpiderEvent . push (coerce f) . unSpiderEvent
2325 {-# INLINE pushCheap #-}
2326 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2327 {-# INLINABLE pull #-}
2328 pull = SpiderBehavior . pull . coerce
2329 {-# INLINABLE merge #-}
2330 merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2331 {-# INLINABLE fan #-}
2332 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2333 {-# INLINABLE switch #-}
2334 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2335 {-# INLINABLE coincidence #-}
2336 coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2337 {-# INLINABLE current #-}
2338 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2339 {-# INLINABLE updated #-}
2340 updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2341 {-# INLINABLE unsafeBuildDynamic #-}
2342 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2343 {-# INLINABLE unsafeBuildIncremental #-}
2344 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2345 {-# INLINABLE mergeIncremental #-}
2346 mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2347 {-# INLINABLE mergeIncrementalWithMove #-}
2348 mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2349 {-# INLINABLE currentIncremental #-}
2350 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2351 {-# INLINABLE updatedIncremental #-}
2352 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2353 {-# INLINABLE incrementalToDynamic #-}
2354 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2355 c <- readBehaviorUntracked $ dynamicCurrent i
2356 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2357 eventCoercion Coercion = Coercion
2358 behaviorCoercion Coercion = Coercion
2359 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2360 {-# INLINABLE mergeIntIncremental #-}
2361 mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2362 {-# INLINABLE fanInt #-}
2363 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2366data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2368data SpiderEventHandle x a = SpiderEventHandle
2369 { spiderEventHandleSubscription :: EventSubscription x
2370 , spiderEventHandleValue :: IORef (Maybe a)
2373instance MonadRef (EventM x) where
2374 type Ref (EventM x) = Ref IO
2375 {-# INLINABLE newRef #-}
2376 {-# INLINABLE readRef #-}
2377 {-# INLINABLE writeRef #-}
2378 newRef = liftIO . newRef
2379 readRef = liftIO . readRef
2380 writeRef r a = liftIO $ writeRef r a
2382instance MonadAtomicRef (EventM x) where
2383 {-# INLINABLE atomicModifyRef #-}
2384 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2386-- | The monad for actions that manipulate a Spider timeline identified by @x@
2387newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2389instance Monad (SpiderHost x) where
2390 {-# INLINABLE (>>=) #-}
2391 SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2392 {-# INLINABLE (>>) #-}
2393 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2394 {-# INLINABLE return #-}
2395 return x = SpiderHost $ return x
2396 {-# INLINABLE fail #-}
2397 fail s = SpiderHost $ fail s
2399-- | Run an action affecting the global Spider timeline; this will be guarded by
2400-- a mutex for that timeline
2401runSpiderHost :: SpiderHost Global a -> IO a
2402runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2404#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2405-- | Run an action affecting a given Spider timeline; this will be guarded by a
2406-- mutex for that timeline
2407runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2408runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2411newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2413instance Monad (SpiderHostFrame x) where
2414 {-# INLINABLE (>>=) #-}
2415 SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2416 {-# INLINABLE (>>) #-}
2417 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2418 {-# INLINABLE return #-}
2419 return x = SpiderHostFrame $ return x
2420 {-# INLINABLE fail #-}
2421 fail s = SpiderHostFrame $ fail s
2423instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2424 notReadyUntil _ = pure ()
2427newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2428newEventWithTriggerIO f = do
2429 es <- newFanEventWithTriggerIO $ \Refl -> f
2430 return $ select es Refl
2432newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2433newFanEventWithTriggerIO f = do
2434 occRef <- newIORef DMap.empty
2435 subscribedRef <- newIORef DMap.empty
2437 { rootOccurrence = occRef
2438 , rootSubscribed = subscribedRef
2441 return $ EventSelector $ \k -> eventRoot k r
2443newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2445instance MonadRef (SpiderHost x) where
2446 type Ref (SpiderHost x) = Ref IO
2447 newRef = SpiderHost . newRef
2448 readRef = SpiderHost . readRef
2449 writeRef r = SpiderHost . writeRef r
2451instance MonadAtomicRef (SpiderHost x) where
2452 atomicModifyRef r = SpiderHost . atomicModifyRef r
2454instance MonadRef (SpiderHostFrame x) where
2455 type Ref (SpiderHostFrame x) = Ref IO
2456 newRef = SpiderHostFrame . newRef
2457 readRef = SpiderHostFrame . readRef
2458 writeRef r = SpiderHostFrame . writeRef r
2460instance MonadAtomicRef (SpiderHostFrame x) where
2461 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2463instance PrimMonad (SpiderHostFrame x) where
2464 type PrimState (SpiderHostFrame x) = PrimState IO
2465 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