1{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiWayIf #-}
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RoleAnnotations #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE PolyKinds #-}
20{-# LANGUAGE DeriveFunctor #-}
21{-# LANGUAGE StandaloneDeriving #-}
22{-# LANGUAGE InstanceSigs #-}
24#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
27{-# OPTIONS_GHC -Wunused-binds #-}
28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
32#if MIN_VERSION_base(4,10,0)
33import Control.Applicative (liftA2)
35import Control.Concurrent
36import Control.Exception
37import Control.Monad hiding (forM, forM_, mapM, mapM_)
38import Control.Monad.Exception
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Primitive
41--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42import Control.Monad.Reader.Class
43import Control.Monad.IO.Class
44import Control.Monad.ReaderIO
45import Control.Monad.Ref
48import Data.Dependent.Map (DMap, DSum (..))
49import qualified Data.Dependent.Map as DMap
50import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
51import qualified Data.FastMutableIntMap as FastMutableIntMap
52import Data.Foldable hiding (concat, elem, sequence_)
53import Data.Functor.Constant
54import Data.Functor.Misc
55import Data.Functor.Product
56import Data.GADT.Compare
57import Data.IntMap.Strict (IntMap)
58import qualified Data.IntMap.Strict as IntMap
60import Data.Kind (Type)
61import Data.Maybe hiding (mapMaybe)
62import Data.Monoid ((<>))
65import Data.Traversable
66import Data.Witherable (Filterable, mapMaybe)
68import GHC.IORef (IORef (..))
71import System.IO.Unsafe
75#ifdef MIN_VERSION_semialign
76#if MIN_VERSION_these(0,8,0)
77import Data.These.Combinators (justThese)
79#if MIN_VERSION_semialign(1,1,0)
80import Data.Zip (Zip (..))
85import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
86import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
87import qualified Data.List.NonEmpty as NonEmpty
88import Data.Monoid (mempty)
89import Data.Tree (Forest, Tree (..), drawForest)
92import Data.FastWeakBag (FastWeakBag)
93import qualified Data.FastWeakBag as FastWeakBag
95import Data.Some (Some(Some))
96import Data.Type.Coercion
97import Data.Profunctor.Unsafe ((#.), (.#))
98import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
99import qualified Data.WeakBag as WeakBag
100import qualified Reflex.Class
101import qualified Reflex.Class as R
102import qualified Reflex.Host.Class
103import Reflex.NotReady.Class
105import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
107#ifdef DEBUG_TRACE_EVENTS
108import qualified Data.ByteString.Char8 as BS8
109import System.IO (stderr)
112#ifdef DEBUG_TRACE_EVENTS
114withStackOneLine :: (BS8.ByteString -> a) -> a
115withStackOneLine expr = unsafePerformIO $ do
116 stack <- currentCallStack
117 return (expr (BS8.pack (unwords (reverse stack))))
121debugPropagate :: Bool
123debugInvalidateHeight :: Bool
125debugInvalidate :: Bool
133debugInvalidateHeight = False
135debugInvalidate = True
137class HasNodeId a where
138 getNodeId :: a -> Int
140instance HasNodeId (Hold x p a) where
141 getNodeId = holdNodeId
143instance HasNodeId (PushSubscribed x a b) where
144 getNodeId = pushSubscribedNodeId
146instance HasNodeId (SwitchSubscribed x a) where
147 getNodeId = switchSubscribedNodeId
149instance HasNodeId (FanSubscribed x a) where
150 getNodeId = fanSubscribedNodeId
152instance HasNodeId (CoincidenceSubscribed x a) where
153 getNodeId = coincidenceSubscribedNodeId
155instance HasNodeId (RootSubscribed x a) where
156 getNodeId = rootSubscribedNodeId
158instance HasNodeId (Pull x a) where
159 getNodeId = pullNodeId
161{-# INLINE showNodeId #-}
162showNodeId :: HasNodeId a => a -> String
163showNodeId = ("#"<>) . show . getNodeId
165showSubscriberType :: Subscriber x a -> String
166showSubscriberType = \case
167 SubscriberPush _ _ -> "SubscriberPush"
168 SubscriberMerge _ _ -> "SubscriberMerge"
169 SubscriberFan _ -> "SubscriberFan"
170 SubscriberMergeChange _ -> "SubscriberMergeChange"
171 SubscriberHold _ -> "SubscriberHold"
172 SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
173 SubscriberSwitch _ -> "SubscriberSwitch"
174 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
175 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
176 SubscriberHandle -> "SubscriberHandle"
178showEventType :: Event x a -> String
180 EventRoot _ _ -> "EventRoot"
181 EventNever -> "EventNever"
182 EventPush _ -> "EventPush"
183 EventMerge _ -> "EventMerge"
184 EventFan _ _ -> "EventFan"
185 EventSwitch _ -> "EventSwitch"
186 EventCoincidence _ -> "EventCoincidence"
187 EventHold _ -> "EventHold"
188 EventDyn _ -> "EventDyn"
189 EventHoldIdentity _ -> "EventHoldIdentity"
190 EventDynIdentity _ -> "EventDynIdentity"
194debugPropagate = False
196debugInvalidateHeight = False
198debugInvalidate = False
200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
201{-# INLINE showNodeId #-}
202showNodeId :: a -> String
208{-# NOINLINE nextNodeIdRef #-}
209nextNodeIdRef :: IORef Int
210nextNodeIdRef = unsafePerformIO $ newIORef 1
213newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
216--------------------------------------------------------------------------------
218--------------------------------------------------------------------------------
220--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
221-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
222data EventSubscription x = EventSubscription
223 { _eventSubscription_unsubscribe :: !(IO ())
224 , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
227unsubscribe :: EventSubscription x -> IO ()
228unsubscribe (EventSubscription u _) = u
230--------------------------------------------------------------------------------
232--------------------------------------------------------------------------------
234newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
236{-# INLINE subscribeAndRead #-}
237subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
238subscribeAndRead = unEvent
241"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
242"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
243"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
246-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
247-- caching; if the computation function is very cheap, this is (much) more
248-- efficient than 'push'
249{-# INLINE [1] pushCheap #-}
250pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
251pushCheap !f e = Event $ \sub -> do
252 (subscription, occ) <- subscribeAndRead e $ sub
253 { subscriberPropagate = \a -> do
255 mapM_ (subscriberPropagate sub) mb
257 occ' <- join <$> mapM f occ
258 return (subscription, occ')
260-- | A subscriber that never triggers other 'Event's
261{-# INLINE terminalSubscriber #-}
262terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
263terminalSubscriber p = Subscriber
264 { subscriberPropagate = p
265 , subscriberInvalidateHeight = \_ -> return ()
266 , subscriberRecalculateHeight = \_ -> return ()
269-- | Subscribe to an Event only for the duration of one occurrence
270{-# INLINE subscribeAndReadHead #-}
271subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
272subscribeAndReadHead e sub = do
273 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
274 (subscription, occ) <- subscribeAndRead e $ sub
275 { subscriberPropagate = \a -> do
276 liftIO $ unsubscribe =<< readIORef subscriptionRef
277 subscriberPropagate sub a
280 Nothing -> writeIORef subscriptionRef $! subscription
281 Just _ -> unsubscribe subscription
282 return (subscription, occ)
284--TODO: Make this lazy in its input event
285headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
287 parent <- liftIO $ newIORef $ Just originalE
288 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
289 let clearParent = liftIO $ writeIORef parent Nothing
290 (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
291 when (isJust occ) clearParent
292 return $ Event $ \sub -> do
293 liftIO (readIORef parent) >>= \case
294 Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
295 Just e -> subscribeAndReadHead e sub
297data CacheSubscribed x a
298 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
299 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
300 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
303-- | Construct an 'Event' whose value is guaranteed not to be recomputed
306--TODO: Try a caching strategy where we subscribe directly to the parent when
307--there's only one subscriber, and then build our own FastWeakBag only when a second
309{-# NOINLINE [0] cacheEvent #-}
310cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
312#ifdef DEBUG_TRACE_EVENTS
313 withStackOneLine $ \callSite -> Event $
318 mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
319 <- newIORef emptyFastWeak
320 pure $ \sub -> {-# SCC "cacheEvent" #-} do
321#ifdef DEBUG_TRACE_EVENTS
322 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
324 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
325 Just subscribedTicket -> return subscribedTicket
327 subscribers <- liftIO FastWeakBag.empty
328 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
329 (parentSub, occ) <- subscribeAndRead e $ Subscriber
330 { subscriberPropagate = \a -> do
331 liftIO $ writeIORef occRef $ Just a
333 propagateFast a subscribers
334 , subscriberInvalidateHeight = \old -> do
335 FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old
336 , subscriberRecalculateHeight = \new -> do
337 FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new
339 when (isJust occ) $ do
340 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
342 let !subscribed = CacheSubscribed
343 { _cacheSubscribed_subscribers = subscribers
344 , _cacheSubscribed_parent = parentSub
345 , _cacheSubscribed_occurrence = occRef
347 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
348 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
349 return subscribedTicket
351 subscribed <- getFastWeakTicketValue subscribedTicket
352 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
353 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
354 let es = EventSubscription
355 { _eventSubscription_unsubscribe = do
356 FastWeakBag.remove ticket
357 isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
359 writeIORef mSubscribedRef emptyFastWeak
360 unsubscribe $ _cacheSubscribed_parent subscribed
362 touch subscribedTicket
363 , _eventSubscription_subscribed = EventSubscribed
364 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
365 , eventSubscribedRetained = toAny subscribedTicket
370subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
371subscribe e s = fst <$> subscribeAndRead e s
374wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
375wrap tag getSpecificSubscribed sub = do
376 (sln, subd, occ) <- getSpecificSubscribed sub
378 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
380eventRoot :: GCompare k => k a -> Root x k -> Event x a
381eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
383eventNever :: Event x a
384eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
386eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
387eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
389eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
390eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
392eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
393eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
395eventHold :: Hold x p -> Event x p
396eventHold !h = Event $ subscribeHoldEvent h
398eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
399eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
401{-# INLINE subscribeCoincidenceInner #-}
402subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)
403subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
404 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
405 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
406 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
407 let height = max innerHeight outerHeight
408 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
409 return (innerOcc, height, innerSubd)
411--------------------------------------------------------------------------------
413--------------------------------------------------------------------------------
415data Subscriber x a = Subscriber
416 { subscriberPropagate :: !(a -> EventM x ())
417 , subscriberInvalidateHeight :: !(Height -> IO ())
418 , subscriberRecalculateHeight :: !(Height -> IO ())
421--TODO: Move this comment to WeakBag
422-- These function are constructor functions that are marked NOINLINE so they are
423-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
424-- so any weak references that are attached to the constructors will have their
425-- finalizer run. Using the opaque constructor, does not see the
426-- constructor application, so it behaves like an IORef and cannot be fused away.
428-- The result is also evaluated to WHNF, since forcing a thunk invalidates
429-- the weak pointer to it in some cases.
431newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
432newSubscriberHold h = return $ Subscriber
433 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
434 , subscriberInvalidateHeight = \_ -> return ()
435 , subscriberRecalculateHeight = \_ -> return ()
438newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
439newSubscriberFan subscribed = return $ Subscriber
440 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
441 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
442 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
443 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
444 scheduleClear $ fanSubscribedOccurrence subscribed
445 let f _ (Pair v subsubs) = do
446 propagate v $ _fanSubscribedChildren_list subsubs
448 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
450 , subscriberInvalidateHeight = \old -> do
451 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
452 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
453 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
454 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
455 , subscriberRecalculateHeight = \new -> do
456 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
457 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
458 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
459 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
462newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
463newSubscriberSwitch subscribed = return $ Subscriber
464 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
465 tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
466 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
467 scheduleClear $ switchSubscribedOccurrence subscribed
468 propagate a $ switchSubscribedSubscribers subscribed
469 , subscriberInvalidateHeight = \_ -> do
470 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
471 oldHeight <- readIORef $ switchSubscribedHeight subscribed
472 when (oldHeight /= invalidHeight) $ do
473 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
474 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
475 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
476 , subscriberRecalculateHeight = \new -> do
477 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
478 updateSwitchHeight new subscribed
479 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
482newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
483newSubscriberCoincidenceOuter subscribed = return $ Subscriber
484 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
485 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
486 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
487 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
488 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
489 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
490 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
491 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
492 scheduleClear $ coincidenceSubscribedInnerParent subscribed
495 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
496 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
497 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
498 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
499 Just o -> do -- Since it's already firing, no need to adjust height
500 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
501 scheduleClear $ coincidenceSubscribedOccurrence subscribed
502 propagate o $ coincidenceSubscribedSubscribers subscribed
503 , subscriberInvalidateHeight = \_ -> do
504 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
505 invalidateCoincidenceHeight subscribed
506 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
507 , subscriberRecalculateHeight = \_ -> do
508 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
509 recalculateCoincidenceHeight subscribed
510 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
513newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
514newSubscriberCoincidenceInner subscribed = return $ Subscriber
515 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
516 tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
517 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
519 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
521 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
522 scheduleClear $ coincidenceSubscribedOccurrence subscribed
523 propagate a $ coincidenceSubscribedSubscribers subscribed
524 , subscriberInvalidateHeight = \_ -> do
525 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
526 invalidateCoincidenceHeight subscribed
527 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
528 , subscriberRecalculateHeight = \_ -> do
529 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
530 recalculateCoincidenceHeight subscribed
531 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
534invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
535invalidateSubscriberHeight = flip subscriberInvalidateHeight
537recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
538recalculateSubscriberHeight = flip subscriberRecalculateHeight
540-- | Propagate everything at the current height
541propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
542propagate a subscribers = withIncreasedDepth $ do
543 -- 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
544 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
545 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
547-- | Propagate everything at the current height
548propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
549propagateFast a subscribers = withIncreasedDepth $ do
550 -- 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
551 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
552 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
554--------------------------------------------------------------------------------
556--------------------------------------------------------------------------------
561-- Why do we use Any here, instead of just giving eventSubscribedRetained an
562-- existential type? Sadly, GHC does not currently know how to unbox types
563-- with existentially quantified fields. So instead we just coerce values
564-- to type Any on the way in. Since we never coerce them back, this is
566data EventSubscribed x = EventSubscribed
567 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
568 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
570 , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
571 , eventSubscribedHasOwnHeightRef :: !Bool
572 , eventSubscribedWhoCreated :: !(IO [String])
576eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
577eventSubscribedRoot !r = EventSubscribed
578 { eventSubscribedHeightRef = zeroRef
579 , eventSubscribedRetained = toAny r
581 , eventSubscribedGetParents = return []
582 , eventSubscribedHasOwnHeightRef = False
583 , eventSubscribedWhoCreated = return ["root"]
587eventSubscribedNever :: EventSubscribed x
588eventSubscribedNever = EventSubscribed
589 { eventSubscribedHeightRef = zeroRef
590 , eventSubscribedRetained = toAny ()
592 , eventSubscribedGetParents = return []
593 , eventSubscribedHasOwnHeightRef = False
594 , eventSubscribedWhoCreated = return ["never"]
598eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
599eventSubscribedFan !subscribed = EventSubscribed
600 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
601 , eventSubscribedRetained = toAny subscribed
603 , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
604 , eventSubscribedHasOwnHeightRef = False
605 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
609eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
610eventSubscribedSwitch !subscribed = EventSubscribed
611 { eventSubscribedHeightRef = switchSubscribedHeight subscribed
612 , eventSubscribedRetained = toAny subscribed
614 , eventSubscribedGetParents = do
615 s <- readIORef $ switchSubscribedCurrentParent subscribed
616 return [Some $ _eventSubscription_subscribed s]
617 , eventSubscribedHasOwnHeightRef = True
618 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
622eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
623eventSubscribedCoincidence !subscribed = EventSubscribed
624 { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
625 , eventSubscribedRetained = toAny subscribed
627 , eventSubscribedGetParents = do
628 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
629 let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
630 innerParents = maybeToList $ fmap Some innerSubscription
631 return $ outerParent : innerParents
632 , eventSubscribedHasOwnHeightRef = True
633 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
637getEventSubscribedHeight :: EventSubscribed x -> IO Height
638getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
641whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
642whoCreatedEventSubscribed = eventSubscribedWhoCreated
644walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
645walkInvalidHeightParents s0 = do
646 subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
647 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
648 when (h == invalidHeight) $ do
649 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
651 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
652 forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
656{-# INLINE subscribeHoldEvent #-}
657subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
658subscribeHoldEvent = subscribeAndRead . holdEvent
660--------------------------------------------------------------------------------
662--------------------------------------------------------------------------------
664newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
666behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
667behaviorHold !h = Behavior $ readHoldTracked h
669behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
670behaviorHoldIdentity = behaviorHold
672behaviorConst :: a -> Behavior x a
673behaviorConst !a = Behavior $ return a
675behaviorPull :: Pull x a -> Behavior x a
676behaviorPull !p = Behavior $ do
677 val <- liftIO $ readIORef $ pullValue p
679 Just subscribed -> do
680 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
681 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
682 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
683 return $ pullSubscribedValue subscribed
685 i <- liftIO $ newInvalidatorPull p
686 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
687 parentsRef <- liftIO $ newIORef []
688 holdInits <- askBehaviorHoldInits
689 a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
690 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
691 parents <- liftIO $ readIORef parentsRef
692 let subscribed = PullSubscribed
693 { pullSubscribedValue = a
694 , pullSubscribedInvalidators = invsRef
695 , pullSubscribedOwnInvalidator = i
696 , pullSubscribedParents = parents
698 liftIO $ writeIORef (pullValue p) $ Just subscribed
699 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
702behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
703behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
705{-# INLINE readHoldTracked #-}
706readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
707readHoldTracked h = do
708 result <- liftIO $ readIORef $ holdValue h
709 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
710 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
711 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
714{-# INLINABLE readBehaviorUntracked #-}
715readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
716readBehaviorUntracked b = do
717 holdInits <- getDeferralQueue
718 liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
720--------------------------------------------------------------------------------
722--------------------------------------------------------------------------------
724type DynamicS x p = Dynamic x (PatchTarget p) p
726data Dynamic x target p = Dynamic
727 { dynamicCurrent :: !(Behavior x target)
728 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
731deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
736dynamicHold :: Hold x p -> DynamicS x p
737dynamicHold !h = Dynamic
738 { dynamicCurrent = behaviorHold h
739 , dynamicUpdated = eventHold h
742dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
743dynamicHoldIdentity = dynamicHold
745dynamicConst :: PatchTarget p -> DynamicS x p
746dynamicConst !a = Dynamic
747 { dynamicCurrent = behaviorConst a
748 , dynamicUpdated = eventNever
751dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
752dynamicDyn !d = Dynamic
753 { dynamicCurrent = behaviorDyn d
754 , dynamicUpdated = eventDyn d
757dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
758dynamicDynIdentity = dynamicDyn
760--------------------------------------------------------------------------------
762--------------------------------------------------------------------------------
764--type role Hold representational
766 = Hold { holdValue :: !(IORef (PatchTarget p))
767 , holdInvalidators :: !(IORef [Weak (Invalidator x)])
768 , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
769 , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
775-- | A statically allocated 'SpiderTimeline'
778{-# NOINLINE globalSpiderTimelineEnv #-}
779globalSpiderTimelineEnv :: SpiderTimelineEnv Global
780globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
782-- | Stores all global data relevant to a particular Spider timeline; only one
783-- value should exist for each type @x@
784newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
785-- We implement SpiderTimelineEnv with a newtype wrapper so
786-- we can get the coercions we want safely.
787type role SpiderTimelineEnv nominal
789data SpiderTimelineEnv' x = SpiderTimelineEnv
790 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
791 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
793 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
796type role SpiderTimelineEnv' phantom
798instance Eq (SpiderTimelineEnv x) where
799 _ == _ = True -- Since only one exists of each type
801instance GEq SpiderTimelineEnv where
802 a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
803 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
807 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
808 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
809 , eventEnvDynInits :: !(IORef [SomeDynInit x])
810 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
811 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
812 , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe
813 , eventEnvIntClears :: !(IORef [Some IntClear])
814 , eventEnvRootClears :: !(IORef [Some RootClear])
815 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
816 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
817 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
820{-# INLINE runEventM #-}
821runEventM :: EventM x a -> IO a
824asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
825asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
827class MonadIO m => Defer a m where
828 getDeferralQueue :: m (IORef [a])
831defer :: Defer a m => a -> m ()
833 q <- getDeferralQueue
834 liftIO $ modifyIORef' q (a:)
836instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
837 {-# INLINE getDeferralQueue #-}
838 getDeferralQueue = asksEventEnv eventEnvAssignments
840instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
841 {-# INLINE getDeferralQueue #-}
842 getDeferralQueue = asksEventEnv eventEnvHoldInits
844instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
845 {-# INLINE getDeferralQueue #-}
846 getDeferralQueue = asksEventEnv eventEnvDynInits
848instance Defer (SomeHoldInit x) (BehaviorM x) where
849 {-# INLINE getDeferralQueue #-}
850 getDeferralQueue = BehaviorM $ asks snd
852instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
853 {-# INLINE getDeferralQueue #-}
854 getDeferralQueue = asksEventEnv eventEnvMergeUpdates
856instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
857 {-# INLINE getDeferralQueue #-}
858 getDeferralQueue = asksEventEnv eventEnvMergeInits
860class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
861 getCurrentHeight :: m Height
862 scheduleMerge :: Height -> EventM x () -> m ()
864instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
865 {-# INLINE getCurrentHeight #-}
866 getCurrentHeight = do
867 heightRef <- asksEventEnv eventEnvCurrentHeight
868 liftIO $ readIORef heightRef
869 {-# INLINE scheduleMerge #-}
870 scheduleMerge height subscribed = do
871 delayedRef <- asksEventEnv eventEnvDelayedMerges
872 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
874class HasSpiderTimeline x where
875 -- | Retrieve the current SpiderTimelineEnv
876 spiderTimeline :: SpiderTimelineEnv x
878instance HasSpiderTimeline Global where
879 spiderTimeline = globalSpiderTimelineEnv
881putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
882putCurrentHeight h = do
883 heightRef <- asksEventEnv eventEnvCurrentHeight
884 liftIO $ writeIORef heightRef $! h
886instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
887 {-# INLINE getDeferralQueue #-}
888 getDeferralQueue = asksEventEnv eventEnvClears
890{-# INLINE scheduleClear #-}
891scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
892scheduleClear r = defer $ Some $ Clear r
894instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
895 {-# INLINE getDeferralQueue #-}
896 getDeferralQueue = asksEventEnv eventEnvIntClears
898{-# INLINE scheduleIntClear #-}
899scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
900scheduleIntClear r = defer $ Some $ IntClear r
902instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
903 {-# INLINE getDeferralQueue #-}
904 getDeferralQueue = asksEventEnv eventEnvRootClears
906{-# INLINE scheduleRootClear #-}
907scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
908scheduleRootClear r = defer $ Some $ RootClear r
910instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
911 {-# INLINE getDeferralQueue #-}
912 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
914-- Note: hold cannot examine its event until after the phase is over
915{-# INLINE [1] hold #-}
916hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
918 valRef <- liftIO $ newIORef v0
919 invsRef <- liftIO $ newIORef []
920 parentRef <- liftIO $ newIORef Nothing
922 nodeId <- liftIO newNodeId
926 , holdInvalidators = invsRef
928 , holdParent = parentRef
930 , holdNodeId = nodeId
933 defer $ SomeHoldInit h
936{-# INLINE getHoldEventSubscription #-}
937getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
938getHoldEventSubscription h = do
939 ep <- liftIO $ readIORef $ holdParent h
941 Just subd -> return subd
944 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
945 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
946 liftIO $ writeIORef subscriptionRef $! subscription
950 old <- liftIO $ readIORef $ holdValue h
954 -- Need to evaluate these so that we don't retain the Hold itself
955 v <- liftIO $ evaluate $ holdValue h
956 i <- liftIO $ evaluate $ holdInvalidators h
957 defer $ SomeAssignment v i new
958 liftIO $ writeIORef (holdParent h) $ Just subscription
961type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
963-- BehaviorM can sample behaviors
964newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
965 deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
967instance Monad (BehaviorM x) where
969 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
971 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
972 {-# INLINE return #-}
973 return x = BehaviorM $ return x
975 fail s = BehaviorM $ fail s
977data BehaviorSubscribed x a
978 = forall p. BehaviorSubscribedHold (Hold x p)
979 | BehaviorSubscribedPull (PullSubscribed x a)
981newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))
983--type role PullSubscribed representational
984data PullSubscribed x a
985 = PullSubscribed { pullSubscribedValue :: !a
986 , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
987 , pullSubscribedOwnInvalidator :: !(Invalidator x)
988 , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
991--type role Pull representational
993 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
994 , pullCompute :: !(BehaviorM x a)
1001 = forall a. InvalidatorPull (Pull x a)
1002 | forall a. InvalidatorSwitch (SwitchSubscribed x a)
1004data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1005 { rootSubscribedKey :: !(k a)
1006 , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
1007 , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1008 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
1009 , rootSubscribedUninit :: IO ()
1010 , 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?
1012 , rootSubscribedNodeId :: Int
1017 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1018 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1019 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1022data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1024data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1026data SomeMergeUpdate x = SomeMergeUpdate
1027 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1028 , _someMergeUpdate_invalidateHeight :: !(IO ())
1029 , _someMergeUpdate_recalculateHeight :: !(IO ())
1032newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1034-- EventM can do everything BehaviorM can, plus create holds
1035newtype 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
1037newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1039data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1040 { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1041 , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1044data HeightBag = HeightBag
1045 { _heightBag_size :: {-# UNPACK #-} !Int
1046 , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1048 deriving (Show, Read, Eq, Ord)
1050heightBagEmpty :: HeightBag
1051heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1053heightBagSize :: HeightBag -> Int
1054heightBagSize = _heightBag_size
1056heightBagFromList :: [Height] -> HeightBag
1057heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1059heightBagAdd :: Height -> HeightBag -> HeightBag
1060heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1062heightBagRemove :: Height -> HeightBag -> HeightBag
1063heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1064 Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1065 Just old -> HeightBag (pred s) $ case old of
1066 0 -> IntMap.delete h c
1067 _ -> IntMap.insert h (pred old) c
1069heightBagMax :: HeightBag -> Height
1070heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1071 Just ((h, _), _) -> Height h
1072 Nothing -> zeroHeight
1074heightBagVerify :: HeightBag -> HeightBag
1076heightBagVerify b@(HeightBag s c) = if
1077 | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1078 -> error $ "heightBagVerify: size doesn't match: " <> show b
1079 | unHeight invalidHeight `IntMap.member` c
1080 -> error $ "heightBagVerify: contains invalid height: " <> show b
1086data FanSubscribedChildren x k v a = FanSubscribedChildren
1087 { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1088 , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1089 , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1092data FanSubscribed x k v
1093 = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1094 , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1095 , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1096 , fanSubscribedParent :: !(EventSubscription x)
1098 , fanSubscribedNodeId :: Int
1103 = Fan { fanParent :: !(Event x (DMap k v))
1104 , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1107data SwitchSubscribed x a
1108 = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1109 , switchSubscribedOccurrence :: !(IORef (Maybe a))
1110 , switchSubscribedHeight :: !(IORef Height)
1111 , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1112 , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1113 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1114 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1115 , switchSubscribedParent :: !(Behavior x (Event x a))
1116 , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1117 , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1119 , switchSubscribedNodeId :: Int
1124 = Switch { switchParent :: !(Behavior x (Event x a))
1125 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1128#ifdef USE_TEMPLATE_HASKELL
1129{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1131data CoincidenceSubscribed x a
1132 = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1133 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1134 , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1135 , coincidenceSubscribedHeight :: !(IORef Height)
1136 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1137 , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1138 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1139 , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1141 , coincidenceSubscribedNodeId :: Int
1146 = Coincidence { coincidenceParent :: !(Event x (Event x a))
1147 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1150{-# NOINLINE newInvalidatorSwitch #-}
1151newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1152newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1154{-# NOINLINE newInvalidatorPull #-}
1155newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1156newInvalidatorPull p = return $! InvalidatorPull p
1158instance HasSpiderTimeline x => Filterable (Event x) where
1159 mapMaybe f = push $ return . f
1161instance HasSpiderTimeline x => Align (Event x) where
1163#if MIN_VERSION_these(0, 8, 0)
1164instance HasSpiderTimeline x => Semialign (Event x) where
1166 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1167 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1169#ifdef MIN_VERSION_semialign
1170#if MIN_VERSION_semialign(1,1,0)
1171instance HasSpiderTimeline x => Zip (Event x) where
1173 zip x y = mapMaybe justThese $ align x y
1176data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1177 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1178 | HoldDyn !(Hold x p)
1180newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1182newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1183newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1185--TODO: Avoid the duplication between this and R.zipDynWith
1186zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1188 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1189 ec = flip push eab $ \o -> do
1191 This (Identity a) -> do
1192 b <- readBehaviorUntracked $ dynamicCurrent db
1194 That (Identity b) -> do
1195 a <- readBehaviorUntracked $ dynamicCurrent da
1197 These (Identity a) (Identity b) -> return (a, b)
1198 return $ Just $ Identity $ f a b
1199 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1201buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1202buildDynamic readV0 v' = do
1203 result <- liftIO $ newIORef $ BuildDyn (readV0, v')
1205 defer $ SomeDynInit d
1208unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1209unsafeBuildDynamic readV0 v' =
1210 Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1212-- ResultM can read behaviors and events
1213type ResultM = EventM
1215instance HasSpiderTimeline x => Functor (Event x) where
1216 fmap f = push $ return . Just . f
1218instance Functor (Behavior x) where
1219 fmap f = pull . fmap f . readBehaviorTracked
1222push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1223push f e = cacheEvent (pushCheap f e)
1225{-# INLINABLE pull #-}
1226pull :: BehaviorM x a -> Behavior x a
1227pull a = unsafePerformIO $ do
1228 ref <- newIORef Nothing
1232 pure $ behaviorPull $ Pull
1240{-# INLINABLE switch #-}
1241switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1242switch a = unsafePerformIO $ do
1243 ref <- newIORef Nothing
1244 pure $ eventSwitch $ Switch
1246 , switchSubscribed = ref
1249coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1250coincidence a = unsafePerformIO $ do
1251 ref <- newIORef Nothing
1252 pure $ eventCoincidence $ Coincidence
1253 { coincidenceParent = a
1254 , coincidenceSubscribed = ref
1257-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1258run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1260 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1261 let t = spiderTimeline :: SpiderTimelineEnv x
1262 result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1263 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1264 occBefore <- liftIO $ do
1265 occBefore <- readIORef occRef
1266 writeIORef occRef $! DMap.insert k a occBefore
1268 if DMap.null occBefore
1269 then do scheduleRootClear occRef
1272 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1273 propagate a subscribersRef
1274 delayedRef <- asksEventEnv eventEnvDelayedMerges
1276 delayed <- liftIO $ readIORef delayedRef
1277 case IntMap.minViewWithKey delayed of
1278 Nothing -> return ()
1279 Just ((currentHeight, cur), future) -> do
1280 tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1281 putCurrentHeight $ Height currentHeight
1282 liftIO $ writeIORef delayedRef $! future
1286 putCurrentHeight maxBound
1288 tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1291scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1292scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1293 height <- liftIO $ readIORef heightRef
1294 currentHeight <- getCurrentHeight
1295 case height `compare` currentHeight of
1296 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1297 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1300newtype Clear a = Clear (IORef (Maybe a))
1302newtype IntClear a = IntClear (IORef (IntMap a))
1304newtype RootClear k = RootClear (IORef (DMap k Identity))
1306data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1308debugFinalize :: Bool
1309debugFinalize = False
1311mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1312mkWeakPtrWithDebug x debugNote = do
1316 then Just $ putStrLn $ "finalizing: " ++ debugNote
1319type WeakList a = [Weak a]
1321{-# INLINE withIncreasedDepth #-}
1323withIncreasedDepth :: CanTrace x m => m a -> m a
1324withIncreasedDepth a = do
1325 spiderTimeline <- askSpiderTimelineEnv
1326 liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1328 liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1331withIncreasedDepth :: m a -> m a
1332withIncreasedDepth = id
1335type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1337{-# INLINE tracePropagate #-}
1338tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1339tracePropagate p = traceWhen p debugPropagate
1341{-# INLINE traceInvalidate #-}
1342traceInvalidate :: String -> IO ()
1343traceInvalidate = when debugInvalidate . liftIO . putStrLn
1345{-# INLINE traceWhen #-}
1346traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1347traceWhen p b message = traceMWhen p b $ return message
1349{-# INLINE traceMWhen #-}
1350traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1351traceMWhen _ b getMessage = when b $ do
1352 message <- getMessage
1354 spiderTimeline <- askSpiderTimelineEnv
1355 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1359 liftIO $ putStrLn $ replicate d ' ' <> message
1361whoCreatedIORef :: IORef a -> IO [String]
1362whoCreatedIORef (IORef a) = whoCreated $! a
1365groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1368 (x :| xs) : t -> case groupByHead t of
1369 [] -> [(x, xs :| [])]
1371 | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1372 | otherwise -> (x, xs :| []) : l
1374listsToForest :: Eq a => [[a]] -> Forest a
1375listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1378{-# INLINE propagateSubscriberHold #-}
1379propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1380propagateSubscriberHold h a = do
1381 {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1382 invalidators <- liftIO $ readIORef $ holdInvalidators h
1383 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1384 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1385 case {-# SCC "apply" #-} apply a v of
1386 Nothing -> return ()
1388 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1389 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1390 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1391 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1393data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1395runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1396runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1398askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1402 Nothing -> return Nothing
1403 Just (!wi, _) -> return $ Just wi
1405askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1409 Nothing -> return Nothing
1410 Just (_, !p) -> return $ Just p
1412askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1413askBehaviorHoldInits = do
1417{-# INLINE getDynHold #-}
1418getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1420 mh <- liftIO $ readIORef $ unDyn d
1422 HoldDyn h -> return h
1423 UnsafeDyn (readV0, v') -> do
1424 holdInits <- getDeferralQueue
1425 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1427 BuildDyn (readV0, v') -> do
1428 v0 <- liftIO $ runEventM readV0
1433 liftIO $ writeIORef (unDyn d) $ HoldDyn h
1437-- Always refers to 0
1438{-# NOINLINE zeroRef #-}
1439zeroRef :: IORef Height
1440zeroRef = unsafePerformIO $ newIORef zeroHeight
1442getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1443getRootSubscribed k r sub = do
1444 mSubscribed <- readIORef $ rootSubscribed r
1445 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1446 case DMap.lookup k mSubscribed of
1447 Just subscribed -> {-# SCC "hitRoot" #-} do
1448 sln <- subscribeRootSubscribed subscribed sub
1450 return (sln, subscribed, occ)
1451 Nothing -> {-# SCC "missRoot" #-} do
1452 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1453 let !cached = rootSubscribed r
1454 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1455 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1456 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1457 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1458 writeIORef uninitRef $! uninit
1462 let !subscribed = RootSubscribed
1463 { rootSubscribedKey = k
1464 , rootSubscribedCachedSubscribed = cached
1465 , rootSubscribedOccurrence = getOcc
1466 , rootSubscribedSubscribers = subs
1467 , rootSubscribedUninit = uninit
1468 , rootSubscribedWeakSelf = weakSelf
1470 , rootSubscribedNodeId = nid
1473 -- If we die at the same moment that all our children die, they will
1474 -- try to clean us up but will fail because their Weak reference to us
1475 -- will also be dead. So, if we are dying, check if there are any
1476 -- children; since children don't bother cleaning themselves up if
1477 -- their parents are already dead, I don't think there's a race
1478 -- condition here. However, if there are any children, then we can
1479 -- infer that we need to clean ourselves up, so we do.
1481 cs <- readIORef $ _weakBag_children subs
1482 when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1483 writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1484 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
1486 return (sln, subscribed, occ)
1488#ifdef USE_TEMPLATE_HASKELL
1489{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1491cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1492cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1493 rootSubscribedUninit self
1494 modifyIORef' cached $ DMap.delete k
1496{-# INLINE subscribeRootSubscribed #-}
1497subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1498subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1500newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1502data FanInt x a = FanInt
1503 { _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
1504 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1505 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1508newFanInt :: IO (FanInt x a)
1510 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
1511 subscriptionRef <- newIORef $ error "fanInt: no subscription"
1512 occRef <- newIORef $ error "fanInt: no occurrence"
1514 { _fanInt_subscribers = subscribers
1515 , _fanInt_subscriptionRef = subscriptionRef
1516 , _fanInt_occRef = occRef
1519fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1520fanInt p = unsafePerformIO $ do
1522 pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1523 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1524 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1525 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1526 { subscriberPropagate = \m -> do
1527 liftIO $ writeIORef (_fanInt_occRef self) m
1528 scheduleIntClear $ _fanInt_occRef self
1529 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1530 FastWeakBag.traverse_ b $ \s -> do
1531 subscriberPropagate s v
1532 , subscriberInvalidateHeight = \old -> do
1533 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1534 FastWeakBag.traverse_ b $ \s -> do
1535 subscriberInvalidateHeight s old
1536 , subscriberRecalculateHeight = \new -> do
1537 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1538 FastWeakBag.traverse_ b $ \s -> do
1539 subscriberRecalculateHeight s new
1542 writeIORef (_fanInt_subscriptionRef self) subscription
1543 writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1544 scheduleIntClear $ _fanInt_occRef self
1546 b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1548 b <- FastWeakBag.empty
1549 FastMutableIntMap.insert (_fanInt_subscribers self) k b
1552 t <- liftIO $ FastWeakBag.insert sub b
1553 currentOcc <- readIORef (_fanInt_occRef self)
1554 (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1555 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1557{-# INLINABLE getFanSubscribed #-}
1558getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1559getFanSubscribed k f sub = do
1560 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1562 Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1563 sln <- subscribeFanSubscribed k subscribed sub
1564 occ <- readIORef $ fanSubscribedOccurrence subscribed
1565 return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1566 Nothing -> {-# SCC "missFan" #-} do
1567 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1568 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1569 s <- liftIO $ newSubscriberFan subscribedUnsafe
1570 (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1571 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1572 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1573 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1574 occRef <- liftIO $ newIORef parentOcc
1575 when (isJust parentOcc) $ scheduleClear occRef
1577 nid <- liftIO newNodeId
1579 let subscribed = FanSubscribed
1580 { fanSubscribedCachedSubscribed = fanSubscribed f
1581 , fanSubscribedOccurrence = occRef
1582 , fanSubscribedParent = subscription
1583 , fanSubscribedSubscribers = subscribersRef
1585 , fanSubscribedNodeId = nid
1588 let !self = (k, subscribed)
1589 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1590 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1591 liftIO $ writeIORef subscribedRef $! subscribed
1592 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1593 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1595cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1596cleanupFanSubscribed (k, subscribed) = do
1597 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1598 let reducedSubscribers = DMap.delete k subscribers
1599 if DMap.null reducedSubscribers
1601 unsubscribe $ fanSubscribedParent subscribed
1602 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1603 writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1604 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1606{-# INLINE subscribeFanSubscribed #-}
1607subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1608subscribeFanSubscribed k subscribed sub = do
1609 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1610 case DMap.lookup k subscribers of
1611 Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1612 let !self = (k, subscribed)
1613 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1614 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1615 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
1617 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1619{-# INLINABLE getSwitchSubscribed #-}
1620getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1621getSwitchSubscribed s sub = do
1622 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1624 Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1625 sln <- subscribeSwitchSubscribed subscribed sub
1626 occ <- readIORef $ switchSubscribedOccurrence subscribed
1627 return (sln, subscribed, occ)
1628 Nothing -> {-# SCC "missSwitch" #-} do
1629 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1630 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1631 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1632 mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1633 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1634 wiRef <- liftIO $ newIORef wi
1635 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1636 holdInits <- getDeferralQueue
1637 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1638 (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1639 heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1640 subscriptionRef <- liftIO $ newIORef subscription
1641 occRef <- liftIO $ newIORef parentOcc
1642 when (isJust parentOcc) $ scheduleClear occRef
1643 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1644 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1646 nid <- liftIO newNodeId
1648 let !subscribed = SwitchSubscribed
1649 { switchSubscribedCachedSubscribed = switchSubscribed s
1650 , switchSubscribedOccurrence = occRef
1651 , switchSubscribedHeight = heightRef
1652 , switchSubscribedSubscribers = subs
1653 , switchSubscribedOwnInvalidator = i
1654 , switchSubscribedOwnWeakInvalidator = wiRef
1655 , switchSubscribedBehaviorParents = parentsRef
1656 , switchSubscribedParent = switchParent s
1657 , switchSubscribedCurrentParent = subscriptionRef
1658 , switchSubscribedWeakSelf = weakSelf
1660 , switchSubscribedNodeId = nid
1663 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1664 liftIO $ writeIORef subscribedRef $! subscribed
1665 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1666 return (slnForSub, subscribed, parentOcc)
1668cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1669cleanupSwitchSubscribed subscribed = do
1670 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1671 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1672 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1674{-# INLINE subscribeSwitchSubscribed #-}
1675subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1676subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1678{-# INLINABLE getCoincidenceSubscribed #-}
1679getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1680getCoincidenceSubscribed c sub = do
1681 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1683 Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1684 sln <- subscribeCoincidenceSubscribed subscribed sub
1685 occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1686 return (sln, subscribed, occ)
1687 Nothing -> {-# SCC "missCoincidence" #-} do
1688 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1689 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1690 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1691 (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1692 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1693 (occ, height, mInnerSubd) <- case outerOcc of
1694 Nothing -> return (Nothing, outerHeight, Nothing)
1696 (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1697 return (occ, height, Just innerSubd)
1698 occRef <- liftIO $ newIORef occ
1699 when (isJust occ) $ scheduleClear occRef
1700 heightRef <- liftIO $ newIORef height
1701 innerSubdRef <- liftIO $ newIORef mInnerSubd
1702 scheduleClear innerSubdRef
1703 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1704 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1706 nid <- liftIO newNodeId
1708 let subscribed = CoincidenceSubscribed
1709 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1710 , coincidenceSubscribedOccurrence = occRef
1711 , coincidenceSubscribedHeight = heightRef
1712 , coincidenceSubscribedSubscribers = subs
1713 , coincidenceSubscribedOuter = subOuter
1714 , coincidenceSubscribedOuterParent = outerSubscription
1715 , coincidenceSubscribedInnerParent = innerSubdRef
1716 , coincidenceSubscribedWeakSelf = weakSelf
1718 , coincidenceSubscribedNodeId = nid
1721 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1722 liftIO $ writeIORef subscribedRef $! subscribed
1723 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1724 return (slnForSub, subscribed, occ)
1726cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1727cleanupCoincidenceSubscribed subscribed = do
1728 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1729 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1731{-# INLINE subscribeCoincidenceSubscribed #-}
1732subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1733subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1735{-# INLINE mergeG #-}
1736mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1737 => (forall a. q a -> Event x (v a))
1738 -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1739mergeG nt d = cacheEvent (mergeCheap nt d)
1741{-# INLINE mergeWithMove #-}
1742mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1743 => (forall a. q a -> Event x (v a))
1744 -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1745mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1747{-# INLINE [1] mergeCheap #-}
1749 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1750 => (forall a. q a -> Event x (v a))
1751 -> DynamicS x (PatchDMap k q)
1752 -> Event x (DMap k v)
1753mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1755 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1756 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1757 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1758 (mOldSubd, newPs) <- case me of
1759 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1761 let s = subscriber $ return k
1762 subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1763 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1764 let newParent = MergeSubscribedParent subscription
1765 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1766 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1767 forM_ mOldSubd $ \oldSubd -> do
1768 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1769 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1770 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1771 foldM f ([], oldParents) $ DMap.toList p
1773 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1774 getInitialSubscribers initialParents subscriber = do
1775 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1776 let s = subscriber $ return k
1777 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1778 height <- liftIO $ getEventSubscribedHeight parentSubd
1779 return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1780 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1781 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1782 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1785 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1786 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1788{-# INLINE [1] mergeCheapWithMove #-}
1789mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1790 => (forall a. q a -> Event x (v a))
1791 -> DynamicS x (PatchDMapWithMove k q)
1792 -> Event x (DMap k v)
1793mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1795 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1796 updateMe subscriber heightBagRef oldParents p = do
1797 -- Prepare new parents for insertion
1798 let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1799 subscribeParent k e = do
1800 keyRef <- liftIO $ newIORef k
1801 let s = subscriber $ liftIO $ readIORef keyRef
1802 subscription@(EventSubscription _ subd) <- subscribe e s
1804 newParentHeight <- getEventSubscribedHeight subd
1805 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1806 return $ MergeSubscribedParentWithMove subscription keyRef
1807 p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1808 -- Collect old parents for deletion and update the keys of moved parents
1809 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1810 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1812 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1813 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1814 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1816 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1818 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1819 return (toDelete, applyAlways p' oldParents)
1820 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1821 getInitialSubscribers initialParents subscriber = do
1822 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1823 keyRef <- liftIO $ newIORef k
1824 let s = subscriber $ liftIO $ readIORef keyRef
1825 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1826 height <- liftIO $ getEventSubscribedHeight parentSubd
1827 return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1828 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1829 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1830 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1833 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1834 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1836type MergeUpdateFunc k v x p s
1837 = (forall a. EventM x (k a) -> Subscriber x (v a))
1841 -> EventM x ([EventSubscription x], DMap k s)
1843type MergeInitFunc k v q x s
1845 -> (forall a. EventM x (k a) -> Subscriber x (v a))
1846 -> EventM x (DMap k v, [Height], DMap k s)
1848type MergeDestroyFunc k s
1852data Merge x k v s = Merge
1853 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1854 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1855 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1856 , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1857 , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1860invalidateMergeHeight :: Merge x k v s -> IO ()
1861invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1863invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1864invalidateMergeHeight' heightRef sub = do
1865 oldHeight <- readIORef heightRef
1866 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
1867 writeIORef heightRef $! invalidHeight
1868 subscriberInvalidateHeight sub oldHeight
1870revalidateMergeHeight :: Merge x k v s -> IO ()
1871revalidateMergeHeight m = do
1872 currentHeight <- readIORef $ _merge_heightRef m
1873 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1874 heights <- readIORef $ _merge_heightBagRef m
1875 parents <- readIORef $ _merge_parentsRef m
1876 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1877 case heightBagSize heights `compare` DMap.size parents of
1880 let height = succHeight $ heightBagMax heights
1881 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1882 writeIORef (_merge_heightRef m) $! height
1883 subscriberRecalculateHeight (_merge_sub m) height
1884 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1886scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1887scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1888 vals <- liftIO $ readIORef $ _merge_accumRef m
1889 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
1890 --TODO: Assert that m is not empty
1891 subscriberPropagate (_merge_sub m) vals
1893mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1894mergeSubscriber m getKey = Subscriber
1895 { subscriberPropagate = \a -> do
1896 oldM <- liftIO $ readIORef $ _merge_accumRef m
1898 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1899 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1900 liftIO $ writeIORef (_merge_accumRef m) $! newM
1901 when (DMap.null oldM) $ do -- Only schedule the firing once
1902 height <- liftIO $ readIORef $ _merge_heightRef m
1903 --TODO: assertions about height
1904 currentHeight <- getCurrentHeight
1905 when (height <= currentHeight) $ do
1906 if height /= invalidHeight
1908 myStack <- liftIO $ whoCreatedIORef undefined --TODO
1909 error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1912 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1913 stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1914 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1918 error $ "Causality loop found" <> cycleInfo
1919 scheduleMergeSelf m height
1920 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1921 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1922 invalidateMergeHeight m
1923 , subscriberRecalculateHeight = \new -> do
1924 modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1925 revalidateMergeHeight m
1928--TODO: Be able to run as much of this as possible promptly
1929updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1930updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1932 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1933 (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1934 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1935 return subscriptionsToKill
1937{-# INLINE mergeGCheap' #-}
1938mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1939 => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1940mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1941 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1942 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1943 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1944 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1945 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1947 { _merge_parentsRef = parentsRef
1948 , _merge_heightBagRef = heightBagRef
1949 , _merge_heightRef = heightRef
1951 , _merge_accumRef = accumRef
1953 (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1954 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1955 myHeight = if invalidHeight `elem` heights
1957 else succHeight $ heightBagMax myHeightBag
1958 currentHeight <- getCurrentHeight
1959 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1960 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1962 unless (DMap.null accum) $ do
1963 scheduleMergeSelf m myHeight
1964 liftIO $ writeIORef accumRef $! accum
1965 liftIO $ writeIORef heightRef $! myHeight
1966 liftIO $ writeIORef heightBagRef $! myHeightBag
1967 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1968 liftIO $ writeIORef parentsRef $! initialParentState
1969 defer $ SomeMergeInit $ do
1971 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1972 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1973 defer $ updateMerge m updateFunc a
1974 , subscriberInvalidateHeight = \_ -> return ()
1975 , subscriberRecalculateHeight = \_ -> return ()
1977 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1978 forM_ change $ \c -> defer $ updateMerge m updateFunc c
1979 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1980 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1981 -- its subscription.
1982 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1983 let unsubscribeAll = destroy =<< readIORef parentsRef
1984 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1988mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1989mergeInt = cacheEvent . mergeIntCheap
1991{-# INLINABLE mergeIntCheap #-}
1992mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1993mergeIntCheap d = Event $ \sub -> do
1994 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1995 accum <- liftIO $ FastMutableIntMap.newEmpty
1996 heightRef <- liftIO $ newIORef zeroHeight
1997 heightBagRef <- liftIO $ newIORef heightBagEmpty
1998 parents <- liftIO $ FastMutableIntMap.newEmpty
1999 let scheduleSelf = do
2000 height <- liftIO $ readIORef $ heightRef
2001 scheduleMerge' height heightRef $ do
2002 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
2003 subscriberPropagate sub vals
2004 invalidateMyHeight = do
2005 invalidateMergeHeight' heightRef sub
2006 recalculateMyHeight = do
2007 currentHeight <- readIORef heightRef
2008 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?
2009 heights <- readIORef heightBagRef
2010 numParents <- FastMutableIntMap.size parents
2011 case heightBagSize heights `compare` numParents of
2014 let height = succHeight $ heightBagMax heights
2015 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
2016 writeIORef heightRef $! height
2017 subscriberRecalculateHeight sub height
2018 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2019 mySubscriber k = Subscriber
2020 { subscriberPropagate = \a -> do
2021 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2022 liftIO $ FastMutableIntMap.insert accum k a
2023 when wasEmpty scheduleSelf
2024 , subscriberInvalidateHeight = \old -> do
2025 modifyIORef' heightBagRef $ heightBagRemove old
2027 , subscriberRecalculateHeight = \new -> do
2028 modifyIORef' heightBagRef $ heightBagAdd new
2031 forM_ (IntMap.toList initialParents) $ \(k, p) -> do
2032 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
2034 forM_ parentOcc $ FastMutableIntMap.insert accum k
2035 FastMutableIntMap.insert parents k subscription
2036 height <- getEventSubscribedHeight parentSubd
2037 if height == invalidHeight
2038 then writeIORef heightRef invalidHeight
2040 modifyIORef' heightBagRef $ heightBagAdd height
2041 modifyIORef' heightRef $ \oldHeight ->
2042 if oldHeight == invalidHeight
2044 else max (succHeight height) oldHeight
2045 myHeight <- liftIO $ readIORef heightRef
2046 currentHeight <- getCurrentHeight
2047 isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2048 occ <- if currentHeight >= myHeight -- If we should have fired by now
2051 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2052 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2054 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2055 defer $ SomeMergeInit $ do
2056 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2059 let f k newParent = do
2060 subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
2061 newParentHeight <- liftIO $ getEventSubscribedHeight subd
2062 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
2064 newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
2065 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2066 liftIO $ for_ oldParents $ \oldParent -> do
2067 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2068 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2069 return $ IntMap.elems oldParents
2071 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2072 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2074 , subscriberInvalidateHeight = \_ -> return ()
2075 , subscriberRecalculateHeight = \_ -> return ()
2077 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2078 forM_ change $ \c -> defer $ updateMe c
2079 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2080 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2081 -- its subscription.
2082 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2083 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2084 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2088newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2089newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2091fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2092fanG e = unsafePerformIO $ do
2093 ref <- newIORef Nothing
2096 , fanSubscribed = ref
2098 pure $ EventSelectorG $ \k -> eventFan k f
2100runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2101runHoldInits holdInitRef dynInitRef mergeInitRef = do
2102 holdInits <- liftIO $ readIORef holdInitRef
2103 dynInits <- liftIO $ readIORef dynInitRef
2104 mergeInits <- liftIO $ readIORef mergeInitRef
2105 unless (null holdInits && null dynInits && null mergeInits) $ do
2106 liftIO $ writeIORef holdInitRef []
2107 liftIO $ writeIORef dynInitRef []
2108 liftIO $ writeIORef mergeInitRef []
2109 mapM_ initHold holdInits
2110 mapM_ initDyn dynInits
2111 mapM_ unSomeMergeInit mergeInits
2112 runHoldInits holdInitRef dynInitRef mergeInitRef
2114initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2115initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2117initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2118initDyn (SomeDynInit d) = void $ getDynHold d
2120newEventEnv :: IO (EventEnv x)
2122 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2123 holdInitRef <- newIORef []
2124 dynInitRef <- newIORef []
2125 mergeUpdateRef <- newIORef []
2126 mergeInitRef <- newIORef []
2127 heightRef <- newIORef zeroHeight
2128 toClearRef <- newIORef []
2129 toClearIntRef <- newIORef []
2130 toClearRootRef <- newIORef []
2131 coincidenceInfosRef <- newIORef []
2132 delayedRef <- newIORef IntMap.empty
2133 return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2135clearEventEnv :: EventEnv x -> IO ()
2136clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2137 writeIORef toAssignRef []
2138 writeIORef holdInitRef []
2139 writeIORef dynInitRef []
2140 writeIORef mergeUpdateRef []
2141 writeIORef mergeInitRef []
2142 writeIORef heightRef zeroHeight
2143 writeIORef toClearRef []
2144 writeIORef toClearIntRef []
2145 writeIORef toClearRootRef []
2146 writeIORef coincidenceInfosRef []
2147 writeIORef delayedRef IntMap.empty
2149-- | Run an event action outside of a frame
2150runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2151runFrame a = SpiderHost $ do
2152 let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2155 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
2157 result <- runEventM go
2158 toClear <- readIORef $ eventEnvClears env
2159 forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2160 toClearInt <- readIORef $ eventEnvIntClears env
2161 forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2162 toClearRoot <- readIORef $ eventEnvRootClears env
2163 forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2164 toAssign <- readIORef $ eventEnvAssignments env
2165 toReconnectRef <- newIORef []
2166 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2167 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2169 when debugInvalidate $ putStrLn $ "Invalidating Hold"
2170 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2171 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2172 writeIORef (eventEnvMergeUpdates env) []
2173 when debugPropagate $ putStrLn "Updating merges"
2174 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2175 when debugPropagate $ putStrLn "Updating merges done"
2176 toReconnect <- readIORef toReconnectRef
2178 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2179 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2180 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2181 when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2183 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2184 wi' <- mkWeakPtrWithDebug i "wi'"
2185 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2186 writeIORef (switchSubscribedBehaviorParents subscribed) []
2187 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2188 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2189 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
2190 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2191 sub <- newSubscriberSwitch subscribed
2192 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2194 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2195 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2196 EventRoot _ -> "EventRoot"
2197 EventNever -> "EventNever"
2198 _ -> "something else"
2200 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2201 return oldSubscription
2202 liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2203 liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2204 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2205 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2206 parentHeight <- getEventSubscribedHeight subd'
2207 myHeight <- readIORef $ switchSubscribedHeight subscribed
2208 when (parentHeight /= myHeight) $ do
2209 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2210 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2211 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
2212 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2213 unsubscribe subscription
2214 mapM_ invalidateCoincidenceHeight mcs
2215 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2216 mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2217 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2218 height <- calculateSwitchHeight subscribed
2219 updateSwitchHeight height subscribed
2222newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2224{-# INLINE zeroHeight #-}
2226zeroHeight = Height 0
2228{-# INLINE invalidHeight #-}
2229invalidHeight :: Height
2230invalidHeight = Height (-1000)
2233-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2234{-# INLINE invalidHeightBeingTraversed #-}
2235invalidHeightBeingTraversed :: Height
2236invalidHeightBeingTraversed = Height (-1001)
2239{-# INLINE succHeight #-}
2240succHeight :: Height -> Height
2241succHeight h@(Height a) =
2242 if h == invalidHeight
2244 else Height $ succ a
2246invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2247invalidateCoincidenceHeight subscribed = do
2248 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2249 when (oldHeight /= invalidHeight) $ do
2250 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2251 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2253updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2254updateSwitchHeight new subscribed = do
2255 oldHeight <- readIORef $ switchSubscribedHeight subscribed
2256 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2257 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2258 writeIORef (switchSubscribedHeight subscribed) $! new
2259 WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2261recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2262recalculateCoincidenceHeight subscribed = do
2263 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2264 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2265 height <- calculateCoincidenceHeight subscribed
2266 when (height /= invalidHeight) $ do
2267 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2268 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2270calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2271calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2273calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2274calculateCoincidenceHeight subscribed = do
2275 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2276 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2277 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2279data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2281invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2282invalidate toReconnectRef wis = do
2283 forM_ wis $ \wi -> do
2287 traceInvalidate "invalidate Dead"
2288 return () --TODO: Should we clean this up here?
2290 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2292 InvalidatorPull p -> do
2293 traceInvalidate $ "invalidate: Pull" <> showNodeId p
2294 mVal <- readIORef $ pullValue p
2295 forM_ mVal $ \val -> do
2296 writeIORef (pullValue p) Nothing
2297 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2298 InvalidatorSwitch subscribed -> do
2299 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2300 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2301 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
2303--------------------------------------------------------------------------------
2304-- Reflex integration
2305--------------------------------------------------------------------------------
2307-- | Designates the default, global Spider timeline
2308data SpiderTimeline x
2309type role SpiderTimeline nominal
2311-- | The default, global Spider environment
2312type Spider = SpiderTimeline Global
2314instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
2315 {-# INLINABLE sample #-}
2316 sample (SpiderBehavior b) = readBehaviorUntracked b
2318instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
2319 {-# INLINABLE hold #-}
2320 hold = holdSpiderEventM
2321 {-# INLINABLE holdDyn #-}
2322 holdDyn = holdDynSpiderEventM
2323 {-# INLINABLE holdIncremental #-}
2324 holdIncremental = holdIncrementalSpiderEventM
2325 {-# INLINABLE buildDynamic #-}
2326 buildDynamic = buildDynamicSpiderEventM
2327 {-# INLINABLE headE #-}
2329-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2331instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2332 {-# INLINABLE sample #-}
2333 sample = coerce . readBehaviorTracked . unSpiderBehavior
2335instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2336 {-# INLINABLE sample #-}
2337 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2339instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2340 {-# INLINABLE hold #-}
2341 hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
2342 {-# INLINABLE holdDyn #-}
2343 holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
2344 {-# INLINABLE holdIncremental #-}
2345 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
2346 {-# INLINABLE buildDynamic #-}
2347 buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
2348 {-# INLINABLE headE #-}
2350-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2352instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2353 {-# INLINE return #-}
2355 {-# INLINE (>>=) #-}
2356 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2360 fail _ = error "Dynamic does not support 'fail'"
2362{-# INLINABLE newJoinDyn #-}
2363newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2365 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2366 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2367 eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
2368 eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
2369 v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
2370 in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2372instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2373 fmap = mapDynamicSpider
2374 x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2376mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b
2377mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2378{-# INLINE [1] mapDynamicSpider #-}
2380instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2381 pure = SpiderDynamic . dynamicConst
2382#if MIN_VERSION_base(4,10,0)
2383 liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
2385 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
2386 a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]
2387 (<*) = flip (*>) -- There are no effects, so order doesn't matter
2389holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
2390holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2392holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2393holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2395holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
2396holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2398buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2399buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2401instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
2402 {-# INLINABLE hold #-}
2403 hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
2404 {-# INLINABLE holdDyn #-}
2405 holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
2406 {-# INLINABLE holdIncremental #-}
2407 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
2408 {-# INLINABLE buildDynamic #-}
2409 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2410 {-# INLINABLE headE #-}
2411 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2413instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2414 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2416instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2417 {-# INLINABLE hold #-}
2418 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2419 {-# INLINABLE holdDyn #-}
2420 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2421 {-# INLINABLE holdIncremental #-}
2422 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2423 {-# INLINABLE buildDynamic #-}
2424 buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2425 {-# INLINABLE headE #-}
2427-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2429instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2430 {-# INLINABLE sample #-}
2431 sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2433instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2434 {-# INLINABLE sample #-}
2435 sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
2437instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2438 {-# INLINABLE hold #-}
2439 hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
2440 {-# INLINABLE holdDyn #-}
2441 holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
2442 {-# INLINABLE holdIncremental #-}
2443 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
2444 {-# INLINABLE buildDynamic #-}
2445 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2446 {-# INLINABLE headE #-}
2447 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2449--------------------------------------------------------------------------------
2451--------------------------------------------------------------------------------
2453-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
2454{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2455type SpiderEnv = SpiderTimeline
2456instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2457 {-# INLINABLE subscribeEvent #-}
2458 subscribeEvent e = SpiderHostFrame $ do
2459 --TODO: Unsubscribe eventually (manually and/or with weak ref)
2460 val <- liftIO $ newIORef Nothing
2461 subscription <- subscribe (unSpiderEvent e) $ Subscriber
2462 { subscriberPropagate = \a -> do
2463 liftIO $ writeIORef val $ Just a
2465 , subscriberInvalidateHeight = \_ -> return ()
2466 , subscriberRecalculateHeight = \_ -> return ()
2468 return $ SpiderEventHandle
2469 { spiderEventHandleSubscription = subscription
2470 , spiderEventHandleValue = val
2473instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
2474 type EventTrigger (SpiderTimeline x) = RootTrigger x
2475 type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2476 type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2478instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2479 {-# NOINLINE readEvent #-}
2480 readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
2481 result <- readIORef $ spiderEventHandleValue h
2485instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2486 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2487 newFanEventWithTrigger f = SpiderHost $ do
2488 es <- newFanEventWithTriggerIO f
2489 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2491instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2492 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2493 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2494 es <- newFanEventWithTriggerIO f
2495 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2497instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2498 {-# INLINABLE subscribeEvent #-}
2499 subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
2501instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2502 type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
2503 fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
2504 runHostFrame = runFrame . runSpiderHostFrame
2506unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2507unsafeNewSpiderTimelineEnv = do
2511 depthRef <- newIORef 0
2513 return $ STE $ SpiderTimelineEnv
2514 { _spiderTimeline_lock = lock
2515 , _spiderTimeline_eventEnv = env
2517 , _spiderTimeline_depth = depthRef
2521-- | Create a new SpiderTimelineEnv
2522newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2523newSpiderTimeline = withSpiderTimeline (pure . Some)
2525data LocalSpiderTimeline (x :: Type) s
2527instance Reifies s (SpiderTimelineEnv x) =>
2528 HasSpiderTimeline (LocalSpiderTimeline x s) where
2529 spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2533 -> SpiderTimelineEnv x
2534 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2535localSpiderTimeline _ = coerce
2537-- | Pass a new timeline to the given function.
2538withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2539withSpiderTimeline k = do
2540 env <- unsafeNewSpiderTimelineEnv
2541 reify env $ \s -> k $ localSpiderTimeline s env
2543newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2545type ComputeM = EventM
2547newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2549instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2550 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2551 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2552 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2553 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2554 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2555 type PullM (SpiderTimeline x) = SpiderPullM x
2556 type PushM (SpiderTimeline x) = SpiderPushM x
2557 {-# INLINABLE never #-}
2558 never = SpiderEvent eventNever
2559 {-# INLINABLE constant #-}
2560 constant = SpiderBehavior . behaviorConst
2562 push f = SpiderEvent . push (coerce f) . unSpiderEvent
2563 {-# INLINE pushCheap #-}
2564 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2565 {-# INLINABLE pull #-}
2566 pull = SpiderBehavior . pull . coerce
2567 {-# INLINABLE fanG #-}
2568 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2569 {-# INLINABLE mergeG #-}
2571 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2572 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2574 -> R.Event (SpiderTimeline x) (DMap k v)
2575 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2576 {-# INLINABLE switch #-}
2577 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2578 {-# INLINABLE coincidence #-}
2579 coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2580 {-# INLINABLE current #-}
2581 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2582 {-# INLINABLE updated #-}
2583 updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2584 {-# INLINABLE unsafeBuildDynamic #-}
2585 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2586 {-# INLINABLE unsafeBuildIncremental #-}
2587 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2588 {-# INLINABLE mergeIncrementalG #-}
2589 mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2590 {-# INLINABLE mergeIncrementalWithMoveG #-}
2591 mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2592 {-# INLINABLE currentIncremental #-}
2593 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2594 {-# INLINABLE updatedIncremental #-}
2595 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2596 {-# INLINABLE incrementalToDynamic #-}
2597 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2598 c <- readBehaviorUntracked $ dynamicCurrent i
2599 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2600 eventCoercion Coercion = Coercion
2601 behaviorCoercion Coercion = Coercion
2602 dynamicCoercion Coercion = Coercion
2603 incrementalCoercion Coercion Coercion = Coercion
2604 {-# INLINABLE mergeIntIncremental #-}
2605 mergeIntIncremental = SpiderEvent . mergeInt . coerce
2606 {-# INLINABLE fanInt #-}
2607 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2609data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2611data SpiderEventHandle x a = SpiderEventHandle
2612 { spiderEventHandleSubscription :: EventSubscription x
2613 , spiderEventHandleValue :: IORef (Maybe a)
2616instance MonadRef (EventM x) where
2617 type Ref (EventM x) = Ref IO
2618 {-# INLINABLE newRef #-}
2619 {-# INLINABLE readRef #-}
2620 {-# INLINABLE writeRef #-}
2621 newRef = liftIO . newRef
2622 readRef = liftIO . readRef
2623 writeRef r a = liftIO $ writeRef r a
2625instance MonadAtomicRef (EventM x) where
2626 {-# INLINABLE atomicModifyRef #-}
2627 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2629-- | The monad for actions that manipulate a Spider timeline identified by @x@
2630newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2632instance Monad (SpiderHost x) where
2633 {-# INLINABLE (>>=) #-}
2634 SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2635 {-# INLINABLE (>>) #-}
2636 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2637 {-# INLINABLE return #-}
2638 return x = SpiderHost $ return x
2639 {-# INLINABLE fail #-}
2640 fail s = SpiderHost $ fail s
2642-- | Run an action affecting the global Spider timeline; this will be guarded by
2643-- a mutex for that timeline
2644runSpiderHost :: SpiderHost Global a -> IO a
2645runSpiderHost (SpiderHost a) = a
2647-- | Run an action affecting a given Spider timeline; this will be guarded by a
2648-- mutex for that timeline
2649runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2650runSpiderHostForTimeline (SpiderHost a) _ = a
2652newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2653 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2655instance Monad (SpiderHostFrame x) where
2656 {-# INLINABLE (>>=) #-}
2657 SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2658 {-# INLINABLE (>>) #-}
2659 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2660 {-# INLINABLE return #-}
2661 return x = SpiderHostFrame $ return x
2662 {-# INLINABLE fail #-}
2663 fail s = SpiderHostFrame $ fail s
2665instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2666 notReadyUntil _ = pure ()
2669newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2670newEventWithTriggerIO f = do
2671 es <- newFanEventWithTriggerIO $ \Refl -> f
2672 return $ select es Refl
2674newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2675newFanEventWithTriggerIO f = do
2676 occRef <- newIORef DMap.empty
2677 subscribedRef <- newIORef DMap.empty
2679 { rootOccurrence = occRef
2680 , rootSubscribed = subscribedRef
2683 return $ EventSelector $ \k -> eventRoot k r
2685newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2687instance MonadRef (SpiderHost x) where
2688 type Ref (SpiderHost x) = Ref IO
2689 newRef = SpiderHost . newRef
2690 readRef = SpiderHost . readRef
2691 writeRef r = SpiderHost . writeRef r
2693instance MonadAtomicRef (SpiderHost x) where
2694 atomicModifyRef r = SpiderHost . atomicModifyRef r
2696instance MonadRef (SpiderHostFrame x) where
2697 type Ref (SpiderHostFrame x) = Ref IO
2698 newRef = SpiderHostFrame . newRef
2699 readRef = SpiderHostFrame . readRef
2700 writeRef r = SpiderHostFrame . writeRef r
2702instance MonadAtomicRef (SpiderHostFrame x) where
2703 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2705instance PrimMonad (SpiderHostFrame x) where
2706 type PrimState (SpiderHostFrame x) = PrimState IO
2707 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