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