@@ -1,2195 +0,0 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators, FlexibleContexts, ConstraintKinds, MagicHash, UnboxedTuples, FunctionalDependencies #-}
2−module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where
3−
4−import qualified Reflex.Class as R
5−import qualified Reflex.Host.Class as R
6−import Data.WeakBag (WeakBag, WeakBagTicket)
7−import qualified Data.WeakBag as WeakBag
8−
9−import Data.List
10−import Data.IORef
11−import System.Mem.Weak
12−import Data.Foldable
13−import Data.Traversable
14−import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
15−import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
16−import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
17−import Control.Monad.State hiding (mapM, mapM_, forM_, forM, sequence)
18−import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
19−import Data.Some (Some)
20−import qualified Data.Some as Some
21−import Data.Dependent.Map (DMap, DSum (..))
22−import qualified Data.Dependent.Map as DMap
23−import Data.GADT.Compare
24−import Data.Maybe
25−import Data.IntMap (IntMap)
26−import qualified Data.IntMap as IntMap
27−import Control.Monad.Ref
28−import Control.Monad.Exception
29−import Data.Monoid ((<>))
30−import Data.Functor.Compose
31−import Control.Exception
32−import Control.Concurrent
33−import Data.Function
34−import Data.These
35−import Data.Align
36−
37−import GHC.IORef (IORef (..))
38−import GHC.Base (IO (..))
39−import GHC.Stack
40−
41−import System.IO.Unsafe
42−import Unsafe.Coerce
43−import Data.Coerce
44−import Control.Monad.Primitive
45−
46−import qualified Data.List.NonEmpty as NonEmpty
47−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
48−import Data.Tree (Tree (..), Forest, drawForest)
49−
50−-- Note: must come last to silence warnings due to AMP on GHC < 7.10
51−import Prelude hiding (mapM, mapM_, any, sequence, concat)
52−
53−type SubscriberList a = WeakBag (Subscriber a)
54−type SubscriberListTicket a = WeakBagTicket (Subscriber a)
55−
56−debugPropagate :: Bool
57−
58−debugInvalidateHeight :: Bool
59−
60−debugInvalidate :: Bool
61−
62−#ifdef DEBUG
63−
64−#define DEBUG_NODEIDS
65−
66−debugPropagate = True
67−
68−debugInvalidateHeight = False
69−
70−debugInvalidate = True
71−
72−class HasNodeId a where
73− getNodeId :: a -> Int
74−
75−instance HasNodeId (Hold p a) where
76− getNodeId = holdNodeId
77−
78−instance HasNodeId (PushSubscribed a b) where
79− getNodeId = pushSubscribedNodeId
80−
81−instance HasNodeId (SwitchSubscribed a) where
82− getNodeId = switchSubscribedNodeId
83−
84−instance HasNodeId (MergeSubscribed a) where
85− getNodeId = mergeSubscribedNodeId
86−
87−instance HasNodeId (FanSubscribed a) where
88− getNodeId = fanSubscribedNodeId
89−
90−instance HasNodeId (CoincidenceSubscribed a) where
91− getNodeId = coincidenceSubscribedNodeId
92−
93−instance HasNodeId (RootSubscribed a) where
94− getNodeId = rootSubscribedNodeId
95−
96−instance HasNodeId (Pull a) where
97− getNodeId = pullNodeId
98−
99−{-# INLINE showNodeId #-}
100−showNodeId :: HasNodeId a => a -> String
101−showNodeId = ("#"<>) . show . getNodeId
102−
103−#else
104−
105−debugPropagate = False
106−
107−debugInvalidateHeight = False
108−
109−debugInvalidate = False
110−
111−-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
112−{-# INLINE showNodeId #-}
113−showNodeId :: a -> String
114−showNodeId _ = ""
115−
116−#endif
117−
118−#ifdef DEBUG_NODEIDS
119−{-# NOINLINE nextNodeIdRef #-}
120−nextNodeIdRef :: IORef Int
121−nextNodeIdRef = unsafePerformIO $ newIORef 1
122−
123−newNodeId :: IO Int
124−newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
125−
126−{-# NOINLINE unsafeNodeId #-}
127−unsafeNodeId :: a -> Int
128−unsafeNodeId a = unsafePerformIO $ do
129− touch a
130− newNodeId
131−#endif
132−
133−--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
134−--type role Hold representational
135−data Hold p a
136− = Hold { holdValue :: !(IORef a)
137− , holdInvalidators :: !(IORef [Weak Invalidator])
138− , holdParent :: !(IORef (Either (Event (p a)) (EventSubscription (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
139−#ifdef DEBUG_NODEIDS
140− , holdNodeId :: Int
141−#endif
142− }
143−
144−data EventEnv x
145− = EventEnv { eventEnvSpiderEnv :: !(SpiderEnv x)
146− , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe
147− , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe
148− , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])
149− , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe
150− , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
151− , eventEnvRootClears :: !(IORef [SomeRootClear])
152− , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
153− , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe
154− , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
155− }
156−
157−{-# INLINE runEventM #-}
158−runEventM :: EventM x a -> EventEnv x -> IO a
159−runEventM = runReaderT . unEventM
160−
161−class MonadIO m => Defer a m where
162− getDeferralQueue :: m (IORef [a])
163−
164−{-# INLINE defer #-}
165−defer :: Defer a m => a -> m ()
166−defer a = do
167− q <- getDeferralQueue
168− liftIO $ modifyIORef' q (a:)
169−
170−instance Defer SomeAssignment (EventM x) where
171− {-# INLINE getDeferralQueue #-}
172− getDeferralQueue = EventM $ asks eventEnvAssignments
173−
174−instance Defer SomeHoldInit (EventM x) where
175− {-# INLINE getDeferralQueue #-}
176− getDeferralQueue = EventM $ asks eventEnvHoldInits
177−
178−instance Defer SomeHoldInit BehaviorM where
179− {-# INLINE getDeferralQueue #-}
180− getDeferralQueue = BehaviorM $ asks snd
181−
182−instance Defer SomeMergeUpdate (EventM x) where
183− {-# INLINE getDeferralQueue #-}
184− getDeferralQueue = EventM $ asks eventEnvMergeUpdates
185−
186−instance Defer SomeMergeInit (EventM x) where
187− {-# INLINE getDeferralQueue #-}
188− getDeferralQueue = EventM $ asks eventEnvMergeInits
189−
190−class HasCurrentHeight m where
191− getCurrentHeight :: m Height
192− scheduleMerge :: Height -> MergeSubscribed a -> m ()
193−
194−instance HasCurrentHeight (EventM x) where
195− {-# INLINE getCurrentHeight #-}
196− getCurrentHeight = EventM $ do
197− heightRef <- asks eventEnvCurrentHeight
198− liftIO $ readIORef heightRef
199− {-# INLINE scheduleMerge #-}
200− scheduleMerge height subscribed = EventM $ do
201− delayedRef <- asks eventEnvDelayedMerges
202− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]
203−
204−class HasSpiderEnv x m | m -> x where
205− askSpiderEnv :: m (SpiderEnv x)
206−
207−instance HasSpiderEnv x (EventM x) where
208− {-# INLINE askSpiderEnv #-}
209− askSpiderEnv = EventM $ asks eventEnvSpiderEnv
210−
211−instance HasSpiderEnv x (SpiderHost x) where
212− {-# INLINE askSpiderEnv #-}
213− askSpiderEnv = SpiderHost ask
214−
215−putCurrentHeight :: Height -> EventM x ()
216−putCurrentHeight h = EventM $ do
217− heightRef <- asks eventEnvCurrentHeight
218− liftIO $ writeIORef heightRef h
219−
220−instance Defer SomeClear (EventM x) where
221− {-# INLINE getDeferralQueue #-}
222− getDeferralQueue = EventM $ asks eventEnvClears
223−
224−{-# INLINE scheduleClear #-}
225−scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
226−scheduleClear r = defer $ SomeClear r
227−
228−instance Defer SomeRootClear (EventM x) where
229− {-# INLINE getDeferralQueue #-}
230− getDeferralQueue = EventM $ asks eventEnvRootClears
231−
232−{-# INLINE scheduleRootClear #-}
233−scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
234−scheduleRootClear r = defer $ SomeRootClear r
235−
236−instance Defer SomeResetCoincidence (EventM x) where
237− {-# INLINE getDeferralQueue #-}
238− getDeferralQueue = EventM $ asks eventEnvResetCoincidences
239−
240−-- Note: hold cannot examine its event until after the phase is over
241−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> EventM x (Hold p a) #-}
242−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}
243−hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)
244−hold v0 e = do
245− valRef <- liftIO $ newIORef v0
246− invsRef <- liftIO $ newIORef []
247− parentRef <- liftIO $ newIORef $ Left e
248−#ifdef DEBUG_NODEIDS
249− nodeId <- liftIO newNodeId
250−#endif
251− let h = Hold
252− { holdValue = valRef
253− , holdInvalidators = invsRef
254− , holdParent = parentRef
255−#ifdef DEBUG_NODEIDS
256− , holdNodeId = nodeId
257−#endif
258− }
259− defer $ SomeHoldInit h
260− return h
261−
262−{-
263−mkWeakIORefKey :: IORef a -> b -> IO () -> IO (Weak b)
264−mkWeakIORefKey r@(IORef (STRef r#)) b (IO f) = IO $ \s ->
265− case mkWeak# r# b f s of (# s1, w #) -> (# s1, Weak w #)
266−-}
267−
268−{-# INLINE getHoldEventSubscription #-}
269−getHoldEventSubscription :: forall m p a x. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeClear m, R.Patch p, HasCurrentHeight m, Defer SomeMergeInit m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Hold p a -> m (EventSubscription (p a))
270−getHoldEventSubscription h = do
271− ep <- liftIO $ readIORef $ holdParent h
272− case ep of
273− Right subd -> return subd
274− Left e -> do
275− subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
276− {-
277− spiderEnv <- askSpiderEnv
278− weakSubscriptionRef <- liftIO $ mkWeakIORef subscriptionRef $ return ()
279− wh <- liftIO $ mkWeakIORefKey (holdValue h) h $ do
280− msr <- deRefWeak weakSubscriptionRef
281− forM_ msr $ \sr -> do
282− subscription <- readIORef sr
283− atomicModifyIORef (_spiderEnv_toUnsubscribe spiderEnv) $ \x -> (SomeEventSubscription subscription : x, ())
284−-- return ()
285− {-
286− -- What can we do? 1) Detect GCs at the SpiderEnv level, then go over the tree
287− 2) Have a finalizer on every SubscriberListNode that only runs if its parent is still alive, and does a normal unsubscribe if so; this would seem to double the number of weakRefs we use, but perhaps not the weakDepth, so maybe it's OK; we will probably need to move the regular call to unsubscribe into the finalizer and then use finalize instead of that call; we can have a strong reference to the SubscriberListNode, which means we just need a single weak reference to each EventSubscribed, which we can reuse in all of the finalizers that need to (potentially) unsubscribe from it
288−-}
289− -}
290− subscription@(_, subd) <- subscribe e =<< liftIO (newSubscriberHold h)
291− liftIO $ writeIORef subscriptionRef subscription
292− occ <- liftIO $ readEventSubscribed subd
293− case occ of
294− Nothing -> return ()
295− Just o -> do
296− old <- liftIO $ readIORef $ holdValue h
297− case R.apply o old of
298− Nothing -> return ()
299− Just new -> do
300− -- Need to evaluate these so that we don't retain the Hold itself
301− v <- liftIO $ evaluate $ holdValue h
302− i <- liftIO $ evaluate $ holdInvalidators h
303− defer $ SomeAssignment v i new
304− liftIO $ writeIORef (holdParent h) $ Right subscription
305− return subscription
306−
307−type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])
308−
309−--type role BehaviorM representational
310−-- BehaviorM can sample behaviors
311−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT BehaviorEnv IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
312−
313−instance Monad BehaviorM where
314− {-# INLINE (>>=) #-}
315− BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
316− {-# INLINE (>>) #-}
317− BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
318− {-# INLINE return #-}
319− return x = BehaviorM $ return x
320− {-# INLINE fail #-}
321− fail s = BehaviorM $ fail s
322−
323−data BehaviorSubscribed a
324− = forall p. BehaviorSubscribedHold (Hold p a)
325− | BehaviorSubscribedPull (PullSubscribed a)
326−
327−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
328−
329−--type role PullSubscribed representational
330−data PullSubscribed a
331− = PullSubscribed { pullSubscribedValue :: !a
332− , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])
333− , pullSubscribedOwnInvalidator :: !Invalidator
334− , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
335− }
336−
337−--type role Pull representational
338−data Pull a
339− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
340− , pullCompute :: !(BehaviorM a)
341−#ifdef DEBUG_NODEIDS
342− , pullNodeId :: Int
343−#endif
344− }
345−
346−data Invalidator
347− = forall a. InvalidatorPull (Pull a)
348− | forall a. InvalidatorSwitch (SwitchSubscribed a)
349−
350−data RootSubscribed a = forall k. GCompare k => RootSubscribed
351− { rootSubscribedKey :: !(k a)
352− , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root
353− , rootSubscribedSubscribers :: !(SubscriberList a)
354− , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
355− , rootSubscribedUninit :: IO ()
356− , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
357−#ifdef DEBUG_NODEIDS
358− , rootSubscribedNodeId :: Int
359−#endif
360− }
361−
362−data Root (k :: * -> *)
363− = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
364− , rootSubscribed :: !(IORef (DMap k RootSubscribed))
365− , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
366− }
367−
368−data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)
369−
370−data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)
371−
372−data SomeMergeInit = forall k. GCompare k => SomeMergeInit !(MergeSubscribed k) !(Event (R.PatchDMap (DMap k Event)))
373−
374−data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)
375−
376−-- EventM can do everything BehaviorM can, plus create holds
377−newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) 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
378−
379−data PushSubscribed a b
380− = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed a b)))
381− , pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
382− , pushSubscribedHeight :: !(IORef Height)
383− , pushSubscribedSubscribers :: !(SubscriberList b)
384− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now
385− , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed a b)))
386− , pushSubscribedParent :: !(EventSubscription a)
387−#ifdef DEBUG_NODEIDS
388− , pushSubscribedNodeId :: Int
389−#endif
390− }
391−
392−newtype ComputeM a = ComputeM { unComputeM :: ReaderT (IORef [SomeHoldInit]) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
393−
394−instance Defer SomeHoldInit ComputeM where
395− getDeferralQueue = ComputeM ask
396−
397−{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}
398−runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a
399−runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
400−
401−data Push a b
402− = Push { pushCompute :: !(a -> ComputeM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)
403− , pushParent :: !(Event a)
404− , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
405− }
406−
407−data MergeSubscribedParent k a
408− = MergeSubscribedParent { mergeSubscribedParentSubscription :: !(EventSubscription a)
409− , mergeSubscribedParentSubscriber :: !(Subscriber a)
410− }
411−
412−data MergeSubscribed k
413− = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
414− , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
415− , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
416− , mergeSubscribedHeight :: !(IORef Height)
417− , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
418− , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
419− , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
420− , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))
421−#ifdef DEBUG_NODEIDS
422− , mergeSubscribedNodeId :: Int
423−#endif
424− }
425−
426−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
427−data Merge k
428− = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
429− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
430− }
431−
432−data FanSubscribedChildren k a = FanSubscribedChildren
433− { _fanSubscribedChildren_list :: !(SubscriberList a)
434− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
435− }
436−
437−data FanSubscribed k
438− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
439− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
440− , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
441−#ifdef DEBUG_NODEIDS
442− , fanSubscribedNodeId :: Int
443−#endif
444− }
445−
446−data Fan k
447− = Fan { fanParent :: !(Event (DMap k Identity))
448− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
449− }
450−
451−data SwitchSubscribed a
452− = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
453− , switchSubscribedOccurrence :: !(IORef (Maybe a))
454− , switchSubscribedHeight :: !(IORef Height)
455− , switchSubscribedSubscribers :: !(SubscriberList a)
456− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
457− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
458− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
459− , switchSubscribedParent :: !(Behavior (Event a))
460− , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
461− , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
462−#ifdef DEBUG_NODEIDS
463− , switchSubscribedNodeId :: Int
464−#endif
465− }
466−
467−data Switch a
468− = Switch { switchParent :: !(Behavior (Event a))
469− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
470− }
471−
472−data CoincidenceSubscribed a
473− = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
474− , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
475− , coincidenceSubscribedSubscribers :: !(SubscriberList a)
476− , coincidenceSubscribedHeight :: !(IORef Height)
477− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
478− , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
479− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
480− , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
481−#ifdef DEBUG_NODEIDS
482− , coincidenceSubscribedNodeId :: Int
483−#endif
484− }
485−
486−data Coincidence a
487− = Coincidence { coincidenceParent :: !(Event (Event a))
488− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
489− }
490−
491−data Subscriber a
492− = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?
493− | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
494− | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)
495− | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
496− | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)
497− | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)
498− | SubscriberSwitch (SwitchSubscribed a)
499− | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
500− | SubscriberCoincidenceInner (CoincidenceSubscribed a)
501− | SubscriberHandle
502−
503−showSubscriberType :: Subscriber a -> String
504−showSubscriberType = \case
505− SubscriberPush _ _ -> "SubscriberPush"
506− SubscriberMerge _ _ -> "SubscriberMerge"
507− SubscriberFan _ -> "SubscriberFan"
508− SubscriberMergeChange _ -> "SubscriberMergeChange"
509− SubscriberHold _ -> "SubscriberHold"
510− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
511− SubscriberSwitch _ -> "SubscriberSwitch"
512− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
513− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
514− SubscriberHandle -> "SubscriberHandle"
515−
516−data Event a
517− = forall k. GCompare k => EventRoot !(k a) !(Root k)
518− | EventNever
519− | forall b. EventPush !(Push b a)
520− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
521− | forall k. GCompare k => EventFan !(k a) !(Fan k)
522− | EventSwitch !(Switch a)
523− | EventCoincidence !(Coincidence a)
524− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
525− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
526− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
527− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
528−
529−showEventType :: Event a -> String
530−showEventType = \case
531− EventRoot _ _ -> "EventRoot"
532− EventNever -> "EventNever"
533− EventPush _ -> "EventPush"
534− EventMerge _ -> "EventMerge"
535− EventFan _ _ -> "EventFan"
536− EventSwitch _ -> "EventSwitch"
537− EventCoincidence _ -> "EventCoincidence"
538− EventHold _ -> "EventHold"
539− EventDyn _ -> "EventDyn"
540− EventHoldIdentity _ -> "EventHoldIdentity"
541− EventDynIdentity _ -> "EventDynIdentity"
542−
543−type EventSubscription a = (Maybe (SubscriberListTicket a), EventSubscribed a)
544−
545−data EventSubscribed a
546− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
547− | EventSubscribedNever
548− | forall b. EventSubscribedPush !(PushSubscribed b a)
549− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
550− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
551− | EventSubscribedSwitch !(SwitchSubscribed a)
552− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
553−
554−unsubscribe :: EventSubscription a -> IO ()
555−unsubscribe (msln, _) = forM_ msln $ \sln -> WeakBag.remove sln
556−
557−-- These function are constructor functions that are marked NOINLINE so they are
558−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
559−-- so any weak references that are attached to the constructors will have their
560−-- finalizer run. Using the opaque constructor, does not see the
561−-- constructor application, so it behaves like an IORef and cannot be fused away.
562−--
563−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
564−-- the weak pointer to it in some cases.
565−
566−--TODO: I think all of these noinlines are now unnecessary
567−{-# NOINLINE newSubscriberPush #-}
568−newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
569−newSubscriberPush compute subd = return $! SubscriberPush compute subd
570−
571−{-# RULES
572− "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
573− #-}
574−{-# NOINLINE newSubscriberHold #-}
575−newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
576−newSubscriberHold h = return $! SubscriberHold h
577−
578−{-# NOINLINE newSubscriberHoldIdentity #-}
579−newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
580−newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
581−
582−{-# NOINLINE newSubscriberMerge #-}
583−newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
584−newSubscriberMerge k subd = return $! SubscriberMerge k subd
585−
586−{-# NOINLINE newSubscriberMergeChange #-}
587−newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
588−newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
589−
590−{-# NOINLINE newSubscriberFan #-}
591−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
592−newSubscriberFan subd = return $! SubscriberFan subd
593−
594−{-# NOINLINE newSubscriberSwitch #-}
595−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
596−newSubscriberSwitch subd = return $! SubscriberSwitch subd
597−
598−{-# NOINLINE newSubscriberCoincidenceOuter #-}
599−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
600−newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
601−
602−{-# NOINLINE newSubscriberCoincidenceInner #-}
603−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
604−newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
605−
606−{-# NOINLINE newInvalidatorSwitch #-}
607−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
608−newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
609−
610−{-# NOINLINE newInvalidatorPull #-}
611−newInvalidatorPull :: Pull a -> IO Invalidator
612−newInvalidatorPull p = return $! InvalidatorPull p
613−
614−data Dynamic p a
615− = DynamicHold !(Hold p a)
616− | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
617− | DynamicConst !a
618− | DynamicDyn !(Dyn p a)
619− | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
620−
621−{-# INLINE current #-}
622−current :: R.Patch p => Dynamic p a -> Behavior a
623−current = \case
624− DynamicHold h -> BehaviorHold h
625− DynamicHoldIdentity h -> BehaviorHoldIdentity h
626− DynamicConst a -> BehaviorConst a
627− DynamicDyn d -> BehaviorDyn d
628− DynamicDynIdentity d -> BehaviorDynIdentity d
629−
630−--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
631−{-# INLINE updated #-}
632−updated :: R.Patch p => Dynamic p a -> Event (p a)
633−updated = \case
634− DynamicHold h -> EventHold h
635− DynamicHoldIdentity h -> EventHoldIdentity h
636− DynamicConst _ -> EventNever
637− DynamicDyn d -> EventDyn d
638− DynamicDynIdentity d -> EventDynIdentity d
639−
640−newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b
641−newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (fmap (Identity . f . runIdentity) $ updated d)
642−
643−instance Functor (Dynamic Identity) where
644− fmap f d = newMapDyn f d
645−
646−instance Applicative (Dynamic Identity) where
647− pure = DynamicConst
648− (<*>) = zipDynWith ($)
649− _ *> b = b
650− a <* _ = a
651−
652−instance R.FunctorMaybe Event where
653− fmapMaybe f = push $ return . f
654−
655−instance Align Event where
656− nil = EventNever
657− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
658−
659−--TODO: Avoid the duplication between this and R.zipDynWith
660−zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c
661−zipDynWith f da db =
662− let eab = align (updated da) (updated db)
663− ec = flip push eab $ \o -> do
664− (a, b) <- case o of
665− This (Identity a) -> do
666− b <- readBehaviorUntracked $ current db
667− return (a, b)
668− That (Identity b) -> do
669− a <- readBehaviorUntracked $ current da
670− return (a, b)
671− These (Identity a) (Identity b) -> return (a, b)
672− return $ Just $ Identity $ f a b
673− in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec
674−
675−instance Monad (Dynamic Identity) where
676− {-# INLINE return #-}
677− return = pure
678− {-# INLINE (>>=) #-}
679− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
680− {-# INLINE (>>) #-}
681− _ >> y = y
682− {-# INLINE fail #-}
683− fail _ = error "Dynamic does not support 'fail'"
684−
685−newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
686−
687−unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
688−unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
689− where x = (readV0, v')
690−
691−newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
692−newJoinDyn d =
693− let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)
694− eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d
695− eInner = switch $ fmap updated $ current d
696− eBoth = coincidence $ fmap (updated . runIdentity) $ updated d
697− v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
698− in unsafeDyn readV0 v'
699−
700−--type role Behavior representational
701−data Behavior a
702− = forall p. BehaviorHold !(Hold p a)
703− | BehaviorHoldIdentity !(Hold Identity a)
704− | BehaviorConst !a
705− | BehaviorPull !(Pull a)
706− | BehaviorDynIdentity !(Dyn Identity a)
707− | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
708−
709−-- ResultM can read behaviors and events
710−type ResultM = EventM
711−
712−{-# NOINLINE unsafeNewIORef #-}
713−unsafeNewIORef :: a -> b -> IORef b
714−unsafeNewIORef _ b = unsafePerformIO $ newIORef b
715−
716−instance Functor Event where
717− fmap f = push $ return . Just . f
718−
719−instance Functor Behavior where
720− fmap f = pull . liftM f . readBehaviorTracked
721−
722−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
723−push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
724−push f e = EventPush $ Push
725− { pushCompute = f
726− , pushParent = e
727− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
728− }
729−-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
730−
731−{-# NOINLINE pull #-}
732−pull :: BehaviorM a -> Behavior a
733−pull a = BehaviorPull $ Pull
734− { pullCompute = a
735− , pullValue = unsafeNewIORef a Nothing
736−#ifdef DEBUG_NODEIDS
737− , pullNodeId = unsafeNodeId a
738−#endif
739− }
740−
741−{-# NOINLINE switch #-}
742−switch :: Behavior (Event a) -> Event a
743−switch a = EventSwitch $ Switch
744− { switchParent = a
745− , switchSubscribed = unsafeNewIORef a Nothing
746− }
747−
748−coincidence :: Event (Event a) -> Event a
749−coincidence a = EventCoincidence $ Coincidence
750− { coincidenceParent = a
751− , coincidenceSubscribed = unsafeNewIORef a Nothing
752− }
753−
754−propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
755−propagateAndUpdateSubscribersRef subscribersRef a = do
756− propagate a subscribersRef
757−
758−-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
759−run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b
760−run roots after = do
761− tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
762− spiderEnv <- SpiderHost ask
763− result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
764− rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
765− occBefore <- liftIO $ do
766− occBefore <- readIORef occRef
767− writeIORef occRef $! DMap.insert k a occBefore
768− return occBefore
769− if DMap.null occBefore
770− then do scheduleRootClear occRef
771− return $ Just r
772− else return Nothing
773− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
774− propagateAndUpdateSubscribersRef subscribersRef a
775− delayedRef <- EventM $ asks eventEnvDelayedMerges
776− let go = do
777− delayed <- liftIO $ readIORef delayedRef
778− case IntMap.minViewWithKey delayed of
779− Nothing -> return ()
780− Just ((currentHeight, cur), future) -> do
781− tracePropagate $ "Running height " ++ show currentHeight
782− putCurrentHeight $ Height currentHeight
783− liftIO $ writeIORef delayedRef future
784− forM_ cur $ \d -> case d of
785− DelayedMerge subscribed -> do
786− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
787− case height `compare` Height currentHeight of
788− LT -> error "Somehow a merge's height has been decreased after it was scheduled"
789− GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
790− EQ -> do
791− m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
792− liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty
793− --TODO: Assert that m is not empty
794− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m
795− scheduleClear $ mergeSubscribedOccurrence subscribed
796− propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
797− go
798− go
799− putCurrentHeight maxBound
800− after
801− tracePropagate "Done running an event frame"
802− return result
803−
804−data SomeClear = forall a. SomeClear (IORef (Maybe a))
805−
806−data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
807−
808−data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
809−
810−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
811−
812−debugFinalize :: Bool
813−debugFinalize = False
814−
815−mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
816−mkWeakPtrWithDebug x debugNote = do
817− x' <- evaluate x
818− mkWeakPtr x' $
819− if debugFinalize
820− then Just $ putStrLn $ "finalizing: " ++ debugNote
821− else Nothing
822−
823−type WeakList a = [Weak a]
824−
825−{-# INLINE withIncreasedDepth #-}
826−#ifdef DEBUG
827−withIncreasedDepth :: CanTrace x m => m a -> m a
828−withIncreasedDepth a = do
829− spiderEnv <- askSpiderEnv
830− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
831− result <- a
832− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
833− return result
834−#else
835−withIncreasedDepth :: m a -> m a
836−withIncreasedDepth = id
837−#endif
838−
839−type CanTrace x m = (HasSpiderEnv x m, MonadIO m)
840−
841−{-# INLINE tracePropagate #-}
842−tracePropagate :: (CanTrace x m) => String -> m ()
843−tracePropagate = traceWhen debugPropagate
844−
845−{-# INLINE traceSubscribe #-}
846−traceSubscribe :: String -> IO ()
847−traceSubscribe = when debugSubscribe . liftIO . putStrLn
848−
849−{-# INLINE traceInvalidate #-}
850−traceInvalidate :: String -> IO ()
851−traceInvalidate = when debugInvalidate . liftIO . putStrLn
852−
853−{-# INLINE traceWhen #-}
854−traceWhen :: (CanTrace x m) => Bool -> String -> m ()
855−traceWhen b message = traceMWhen b $ return message
856−
857−{-# INLINE traceMWhen #-}
858−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
859−traceMWhen b getMessage = when b $ do
860− message <- getMessage
861−#ifdef DEBUG
862− spiderEnv <- askSpiderEnv
863− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
864−#else
865− let d = 0
866−#endif
867− liftIO $ putStrLn $ replicate d ' ' <> message
868−
869−whoCreatedIORef :: IORef a -> IO [String]
870−whoCreatedIORef (IORef a) = whoCreated $! a
871−
872−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
873−whoCreatedEventSubscribed = \case
874− EventSubscribedRoot _ -> return ["root"]
875− EventSubscribedNever -> return ["never"]
876− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
877− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
878− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
879− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
880− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
881−
882−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
883−walkInvalidHeightParents s0 = do
884− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
885− h <- liftIO $ readIORef $ eventSubscribedHeightRef s
886− when (h == invalidHeight) $ do
887− when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) invalidHeightBeingTraversed
888− modify (Some.This s :)
889− mapM_ loop =<< liftIO (eventSubscribedGetParents s)
890− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) invalidHeight
891− return subscribers
892−
893−groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
894−groupByHead = \case
895− [] -> []
896− (x :| xs) : t -> case groupByHead t of
897− [] -> [(x, xs :| [])]
898− l@((y, yss) : t')
899− | x == y -> (x, xs `NonEmpty.cons` yss) : t'
900− | otherwise -> (x, xs :| []) : l
901−
902−listsToForest :: Eq a => [[a]] -> Forest a
903−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
904−
905−-- | Propagate everything at the current height
906−propagate :: a -> SubscriberList a -> EventM x ()
907−propagate a subscribers = withIncreasedDepth $ do
908− -- 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
909− --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
910− WeakBag.traverse subscribers $ \s -> case s of
911− SubscriberPush compute subscribed -> {-# SCC "traversePush" #-} do
912− tracePropagate $ "SubscriberPush" <> showNodeId subscribed
913− occ <- runComputeM $ compute a
914− case occ of
915− Nothing -> return () -- No need to write a Nothing back into the Ref
916− Just o -> do
917− liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
918− scheduleClear $ pushSubscribedOccurrence subscribed
919− propagate o $ pushSubscribedSubscribers subscribed
920− SubscriberMerge k subscribed -> {-# SCC "traverseMerge" #-} do
921− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
922− oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
923− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge" <> showNodeId subscribed) k (Identity a) oldM
924− tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
925− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! newM
926− when (DMap.null oldM) $ do -- Only schedule the firing once
927− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
928− --TODO: assertions about height
929− currentHeight <- getCurrentHeight
930− when (height <= currentHeight) $ do
931− myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
932− if height /= invalidHeight
933− then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
934− else liftIO $ do
935− nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
936− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
937− error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
938− scheduleMerge height subscribed
939− SubscriberMergeChange subscribed -> {-# SCC "traverseMergeChange" #-} do
940− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
941− defer $ SomeMergeUpdate a subscribed
942− SubscriberFan subscribed -> {-# SCC "traverseFan" #-} do
943− subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
944− tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
945− --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
946− forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
947− Nothing -> do
948− tracePropagate "No subscriber for key"
949− return ()
950− Just subsubs -> do
951− propagate v $ _fanSubscribedChildren_list subsubs
952− return ()
953− SubscriberHold h -> {-# SCC "traverseHold" #-} propagateSubscriberHold h a
954− SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a
955− SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do
956− tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
957− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
958− scheduleClear $ switchSubscribedOccurrence subscribed
959− propagate a $ switchSubscribedSubscribers subscribed
960− SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do
961− tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
962− outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
963− tracePropagate $ " outerHeight = " <> show outerHeight
964− (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
965− tracePropagate $ " isJust occ = " <> show (isJust occ)
966− tracePropagate $ " innerHeight = " <> show innerHeight
967− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
968− scheduleClear $ coincidenceSubscribedInnerParent subscribed
969− case occ of
970− Nothing -> do
971− when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
972− writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
973− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
974− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight
975− Just o -> do -- Since it's already firing, no need to adjust height
976− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
977− scheduleClear $ coincidenceSubscribedOccurrence subscribed
978− propagate o $ coincidenceSubscribedSubscribers subscribed
979− SubscriberCoincidenceInner subscribed -> {-# SCC "traverseCoincidenceInner" #-} do
980− tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
981− occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
982− case occ of
983− Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
984− Nothing -> do
985− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
986− scheduleClear $ coincidenceSubscribedOccurrence subscribed
987− propagate a $ coincidenceSubscribedSubscribers subscribed
988− SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
989−
990−{-# INLINE propagateSubscriberHold #-}
991−propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()
992−propagateSubscriberHold h a = do
993− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
994− invalidators <- liftIO $ readIORef $ holdInvalidators h
995− return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
996− v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
997− case {-# SCC "apply" #-} R.apply a v of
998− Nothing -> return ()
999− Just v' -> do
1000− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1001− vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1002− iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1003− defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1004−
1005−data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1006−
1007−{-# INLINE subscribeCoincidenceInner #-}
1008−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
1009−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
1010− subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1011− subscription@(_, innerSubd) <- subscribe o subInner
1012− innerOcc <- liftIO $ readEventSubscribed innerSubd
1013− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
1014− let height = max innerHeight outerHeight
1015− defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
1016− return (innerOcc, height, innerSubd)
1017−
1018−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1019−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1020−readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1021−readBehaviorUntracked b = do
1022− holdInits <- getDeferralQueue
1023− liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1024−
1025−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a
1026−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1027−
1028−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
1029−askInvalidator = liftM (fmap fst . fst) $ BehaviorM ask
1030−
1031−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
1032−askParentsRef = liftM (fmap snd . fst) $ BehaviorM ask
1033−
1034−askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1035−askBehaviorHoldInits = liftM snd $ BehaviorM ask
1036−
1037−readBehaviorTracked :: Behavior a -> BehaviorM a
1038−readBehaviorTracked b = case b of
1039− BehaviorHold h -> readHoldTracked h
1040− BehaviorHoldIdentity h -> readHoldTracked h
1041− BehaviorConst a -> return a
1042− BehaviorPull p -> do
1043− val <- liftIO $ readIORef $ pullValue p
1044− case val of
1045− Just subscribed -> do
1046− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1047− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
1048− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
1049− return $ pullSubscribedValue subscribed
1050− Nothing -> do
1051− i <- liftIO $ newInvalidatorPull p
1052− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
1053− parentsRef <- liftIO $ newIORef []
1054− holdInits <- askBehaviorHoldInits
1055− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
1056− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
1057− parents <- liftIO $ readIORef parentsRef
1058− let subscribed = PullSubscribed
1059− { pullSubscribedValue = a
1060− , pullSubscribedInvalidators = invsRef
1061− , pullSubscribedOwnInvalidator = i
1062− , pullSubscribedParents = parents
1063− }
1064− liftIO $ writeIORef (pullValue p) $ Just subscribed
1065− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1066− return a
1067− BehaviorDyn d -> readHoldTracked =<< getDynHold d
1068− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1069−
1070−{-# INLINE readHoldTracked #-}
1071−readHoldTracked :: Hold p a -> BehaviorM a
1072−readHoldTracked h = do
1073− result <- liftIO $ readIORef $ holdValue h
1074− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1075− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1076− return result
1077−
1078−{-# INLINE getDynHold #-}
1079−getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)
1080−getDynHold d = do
1081− mh <- liftIO $ readIORef $ unDyn d
1082− case mh of
1083− Right h -> return h
1084− Left (readV0, v') -> do
1085− holdInits <- getDeferralQueue
1086− v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1087− h <- hold v0 v'
1088− liftIO $ writeIORef (unDyn d) $ Right h
1089− return h
1090−
1091−{-
1092−readEvent :: Event a -> ResultM (Maybe a)
1093−readEvent e = case e of
1094− EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
1095− EventNever -> return Nothing
1096− EventPush p -> do
1097− subscribed <- getPushSubscribed p
1098− liftIO $ readPushSubscribed subscribed
1099− EventMerge m -> do
1100− subscribed <- getMergeSubscribed m
1101− liftIO $ readMergeSubscribed subscribed
1102− EventFan k f -> do
1103− subscribed <- getFanSubscribed f
1104− liftIO $ readFanSubscribed k subscribed
1105− EventSwitch s -> do
1106− subscribed <- getSwitchSubscribed s
1107− liftIO $ readSwitchSubscribed subscribed
1108− EventCoincidence c -> do
1109− subscribed <- getCoincidenceSubscribed c
1110− liftIO $ readCoincidenceSubscribed subscribed
1111− EventHold h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1112− EventDyn d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1113− EventHoldIdentity h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1114− EventDynIdentity d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1115−-}
1116−
1117−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1118−readEventSubscribed = \case
1119− EventSubscribedRoot rs -> readRootSubscribed rs
1120− EventSubscribedNever -> return Nothing
1121− EventSubscribedPush ps -> readPushSubscribed ps
1122− EventSubscribedMerge ms -> readMergeSubscribed ms
1123− EventSubscribedFan k fs -> readFanSubscribed k fs
1124− EventSubscribedSwitch ss -> readSwitchSubscribed ss
1125− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1126−
1127−readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1128−readRootSubscribed = rootSubscribedOccurrence
1129−
1130−readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)
1131−readPushSubscribed subscribed = do
1132− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1133− touch $ pushSubscribedSelf subscribed
1134− return result
1135−
1136−readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1137−readMergeSubscribed subscribed = do
1138− result <- readIORef $ mergeSubscribedOccurrence subscribed
1139− touch $ mergeSubscribedParents subscribed
1140− return result
1141−
1142−readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
1143−readFanSubscribed k fs = do
1144− parentOcc <- readEventSubscribed $ snd $ fanSubscribedParent fs
1145− return $ coerce $ DMap.lookup k =<< parentOcc
1146−
1147−readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1148−readSwitchSubscribed subscribed = do
1149− result <- readIORef $ switchSubscribedOccurrence subscribed
1150− touch $ switchSubscribedOwnInvalidator subscribed
1151− return result
1152−
1153−readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)
1154−readCoincidenceSubscribed subscribed = do
1155− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1156− touch $ coincidenceSubscribedOuter subscribed
1157− --TODO: do we need to touch the inner subscriber?
1158− return result
1159−
1160−-- Always refers to 0
1161−{-# NOINLINE zeroRef #-}
1162−zeroRef :: IORef Height
1163−zeroRef = unsafePerformIO $ newIORef zeroHeight
1164−
1165−{-# SPECIALIZE getEventSubscribed :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1166−getEventSubscribed :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1167−getEventSubscribed e sub = case e of
1168− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1169− EventNever -> return (Nothing, EventSubscribedNever)
1170− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
1171− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
1172− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
1173− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
1174− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
1175− EventHold h -> subscribeHoldEvent h sub
1176− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1177− EventHoldIdentity h -> subscribeHoldEvent h sub
1178− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1179− where
1180− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1181− wrap tag getSpecificSubscribed = do
1182− (sln, subd) <- getSpecificSubscribed sub
1183− return (Just sln, tag subd)
1184−
1185−{-# INLINE subscribeHoldEvent #-}
1186−subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1187−subscribeHoldEvent h sub = do
1188− (_, subd) <- getHoldEventSubscription h
1189− sln <- liftIO $ subscribeEventSubscribed subd sub
1190− return (sln, subd)
1191−
1192−{-# INLINE debugSubscribe #-}
1193−debugSubscribe :: Bool
1194−debugSubscribe = False
1195−
1196−{-# INLINE subscribeEventSubscribed #-}
1197−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
1198−subscribeEventSubscribed es sub = case es of
1199− EventSubscribedRoot r -> do
1200− traceSubscribe $ "subscribeEventSubscribed Root"
1201− fmap Just $ subscribeRootSubscribed r sub
1202− EventSubscribedNever -> do
1203− traceSubscribe $ "subscribeEventSubscribed Never"
1204− return Nothing
1205− EventSubscribedPush subscribed -> do
1206− traceSubscribe $ "subscribeEventSubscribed Push"
1207− fmap Just $ subscribePushSubscribed subscribed sub
1208− EventSubscribedFan k subscribed -> do
1209− traceSubscribe $ "subscribeEventSubscribed Fan"
1210− fmap Just $ subscribeFanSubscribed k subscribed sub
1211− EventSubscribedMerge subscribed -> do
1212− traceSubscribe $ "subscribeEventSubscribed Merge"
1213− fmap Just $ subscribeMergeSubscribed subscribed sub
1214− EventSubscribedSwitch subscribed -> do
1215− traceSubscribe $ "subscribeEventSubscribed Switch"
1216− fmap Just $ subscribeSwitchSubscribed subscribed sub
1217− EventSubscribedCoincidence subscribed -> do
1218− traceSubscribe $ "subscribeEventSubscribed Coincidence"
1219− fmap Just $ subscribeCoincidenceSubscribed subscribed sub
1220−
1221−{-# INLINE eventSubscribedHeightRef #-}
1222−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
1223−eventSubscribedHeightRef = \case
1224− EventSubscribedRoot _ -> zeroRef
1225− EventSubscribedNever -> zeroRef
1226− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1227− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ snd $ fanSubscribedParent subscribed
1228− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
1229− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
1230− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
1231−
1232−{-# INLINE eventSubscribedHasOwnHeightRef #-}
1233−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1234−eventSubscribedHasOwnHeightRef = \case
1235− EventSubscribedRoot _ -> False
1236− EventSubscribedNever -> False
1237− EventSubscribedPush _ -> False
1238− EventSubscribedFan _ _ -> False
1239− EventSubscribedMerge _ -> True
1240− EventSubscribedSwitch _ -> True
1241− EventSubscribedCoincidence _ -> True
1242−
1243−{-# INLINE eventSubscribedGetParents #-}
1244−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1245−eventSubscribedGetParents = \case
1246− EventSubscribedRoot _ -> return []
1247− EventSubscribedNever -> return []
1248− EventSubscribedPush subscribed -> return [Some.This $ snd $ pushSubscribedParent subscribed]
1249− EventSubscribedFan _ subscribed -> return [Some.This $ snd $ fanSubscribedParent subscribed]
1250− EventSubscribedMerge subscribed -> do
1251− ps <- readIORef $ mergeSubscribedParents subscribed
1252− return $ fmap (\(_ :=> v) -> Some.This $ snd $ mergeSubscribedParentSubscription v) $ DMap.toList ps
1253− EventSubscribedSwitch subscribed -> do
1254− s <- readIORef $ switchSubscribedCurrentParent subscribed
1255− return [Some.This $ snd s]
1256− EventSubscribedCoincidence subscribed -> do
1257− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1258− let outerParent = Some.This $ snd $ coincidenceSubscribedOuterParent subscribed
1259− innerParents = maybeToList $ fmap Some.This innerSubscription
1260− return $ outerParent : innerParents
1261−
1262−type CanSubscribe x m =
1263− ( HasSpiderEnv x m
1264− , HasCurrentHeight m
1265− , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1266− , Defer SomeClear m -- Wiping out event firings
1267− , Defer SomeAssignment m -- Updating state
1268− , Defer SomeResetCoincidence m
1269− )
1270−
1271−{-# INLINE subscribe #-}
1272−subscribe :: CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1273−subscribe = getEventSubscribed
1274−
1275−getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
1276−getRootSubscribed k r sub = do
1277− mSubscribed <- readIORef $ rootSubscribed r
1278− case DMap.lookup k mSubscribed of
1279− Just subscribed -> {-# SCC "hitRoot" #-} do
1280− sln <- subscribeRootSubscribed subscribed sub
1281− return (sln, subscribed)
1282− Nothing -> {-# SCC "missRoot" #-} do
1283− weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1284− let !cached = rootSubscribed r
1285− uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1286− (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1287− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1288− uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1289− writeIORef uninitRef uninit
1290− let subscribed = RootSubscribed
1291− { rootSubscribedKey = k
1292− , rootSubscribedCachedSubscribed = cached
1293− , rootSubscribedOccurrence = liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1294− , rootSubscribedSubscribers = subs
1295− , rootSubscribedUninit = uninit
1296− , rootSubscribedWeakSelf = weakSelf
1297−#ifdef DEBUG_NODEIDS
1298− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1299−#endif
1300− }
1301− writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1302− modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root" <> showNodeId r) k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1303− return (sln, subscribed)
1304−
1305−cleanupRootSubscribed :: RootSubscribed a -> IO ()
1306−cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1307− rootSubscribedUninit self
1308− modifyIORef' cached $ DMap.delete k
1309−
1310−{-# INLINE subscribeRootSubscribed #-}
1311−subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1312−subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1313−
1314−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1315−{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}
1316−getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)
1317−getPushSubscribed p sub = do
1318− mSubscribed <- liftIO $ readIORef $ pushSubscribed p
1319− case mSubscribed of
1320− Just subscribed -> {-# SCC "hitPush" #-} do
1321− sln <- liftIO $ subscribePushSubscribed subscribed sub
1322− return (sln, subscribed)
1323− Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
1324− subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
1325− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1326− s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
1327− subscription@(_, subd) <- subscribe (pushParent p) s
1328− parentOcc <- liftIO $ readEventSubscribed subd
1329− occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc
1330− occRef <- liftIO $ newIORef occ
1331− when (isJust occ) $ scheduleClear occRef
1332− weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"
1333− let !cached = pushSubscribed p
1334− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupPushSubscribed
1335− let subscribed = PushSubscribed
1336− { pushSubscribedCachedSubscribed = cached
1337− , pushSubscribedOccurrence = occRef
1338− , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
1339− , pushSubscribedSubscribers = subs
1340− , pushSubscribedSelf = s
1341− , pushSubscribedWeakSelf = weakSelf
1342− , pushSubscribedParent = subscription
1343−#ifdef DEBUG_NODEIDS
1344− , pushSubscribedNodeId = unsafeNodeId p
1345−#endif
1346− }
1347− liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1348− liftIO $ writeIORef subscribedRef subscribed
1349− liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
1350− return (sln, subscribed)
1351−
1352−cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1353−cleanupPushSubscribed self = do
1354− unsubscribe $ pushSubscribedParent self
1355− writeIORef (pushSubscribedCachedSubscribed self) Nothing
1356−
1357−{-# INLINE subscribePushSubscribed #-}
1358−subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)
1359−subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
1360−
1361−{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}
1362−getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)
1363−getMergeSubscribed m sub = do
1364− mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
1365− case mSubscribed of
1366− Just subscribed -> {-# SCC "hitMerge" #-} do
1367− sln <- liftIO $ subscribeMergeSubscribed subscribed sub
1368− return (sln, subscribed)
1369− Nothing -> {-# SCC "missMerge" #-} do
1370− subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1371− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1372− initialParents <- readBehaviorUntracked $ current $ mergeParents m
1373− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1374− s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1375− subscription@(_, parentSubd) <- subscribe e s
1376− parentOcc <- liftIO $ readEventSubscribed parentSubd
1377− height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1378− return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))
1379− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers
1380− subscriberHeights = map (\(_, x, _) -> x) subscribers
1381− myHeight = succHeight $ foldr maxHeight zeroHeight subscriberHeights
1382− currentHeight <- getCurrentHeight
1383− let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1384− then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1385− else (Nothing, dm)
1386− when (not $ DMap.null accum) $ do
1387− scheduleMerge myHeight subscribedUnsafe
1388− occRef <- liftIO $ newIORef occ
1389− when (isJust occ) $ scheduleClear occRef
1390− accumRef <- liftIO $ newIORef accum
1391− heightRef <- liftIO $ newIORef myHeight
1392− weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
1393− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
1394− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1395− parentsRef <- liftIO $ newIORef $ DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1396− let !subscribed = MergeSubscribed
1397− { mergeSubscribedCachedSubscribed = mergeSubscribed m
1398− , mergeSubscribedOccurrence = occRef
1399− , mergeSubscribedAccum = accumRef
1400− , mergeSubscribedHeight = heightRef
1401− , mergeSubscribedSubscribers = subs
1402− , mergeSubscribedChange = changeSubdRef
1403− , mergeSubscribedParents = parentsRef
1404− , mergeSubscribedWeakSelf = weakSelf
1405−#ifdef DEBUG_NODEIDS
1406− , mergeSubscribedNodeId = unsafeNodeId m
1407−#endif
1408− }
1409− defer $ SomeMergeInit subscribed $ updated $ mergeParents m
1410− liftIO $ writeIORef subscribedRef subscribed
1411− liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1412− liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
1413− return (sln, subscribed)
1414−
1415−cleanupMergeSubscribed :: MergeSubscribed k -> IO ()
1416−cleanupMergeSubscribed subscribed = do
1417− parents <- readIORef $ mergeSubscribedParents subscribed
1418− forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp
1419− -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty
1420− writeIORef (mergeSubscribedCachedSubscribed subscribed) Nothing -- Get rid of the cached subscribed
1421−
1422−{-# INLINE subscribeMergeSubscribed #-}
1423−subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))
1424−subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
1425−
1426−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}
1427−getFanSubscribed :: (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m, GCompare k) => k a -> Fan k -> Subscriber a -> m (SubscriberListTicket a, FanSubscribed k)
1428−getFanSubscribed k f sub = do
1429− mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1430− case mSubscribed of
1431− Just subscribed -> {-# SCC "hitFan" #-} do
1432− sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1433− return (sln, subscribed)
1434− Nothing -> {-# SCC "missFan" #-} do
1435− subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1436− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1437− s <- liftIO $ newSubscriberFan subscribedUnsafe
1438− subscription <- subscribe (fanParent f) s
1439− weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1440− (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1441− subscribersRef <- liftIO $ newIORef $ DMap.singleton k $ FanSubscribedChildren subsForK weakSelf
1442− let subscribed = FanSubscribed
1443− { fanSubscribedCachedSubscribed = fanSubscribed f
1444− , fanSubscribedParent = subscription
1445− , fanSubscribedSubscribers = subscribersRef
1446−#ifdef DEBUG_NODEIDS
1447− , fanSubscribedNodeId = unsafeNodeId f
1448−#endif
1449− }
1450− liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1451− liftIO $ writeIORef subscribedRef subscribed
1452− liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1453− return (slnForSub, subscribed)
1454−
1455−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1456−cleanupFanSubscribed (k, subscribed) = do
1457− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1458− let reducedSubscribers = DMap.delete k subscribers
1459− if DMap.null reducedSubscribers
1460− then do
1461− unsubscribe $ fanSubscribedParent subscribed
1462− -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1463− writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1464− else writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1465−
1466−{-# INLINE subscribeFanSubscribed #-}
1467−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)
1468−subscribeFanSubscribed k subscribed sub = do
1469− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1470− case DMap.lookup k subscribers of
1471− Nothing -> do
1472− weakSelf <- newIORef =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1473− (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1474− writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeEventSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list weakSelf) subscribers
1475− return sln
1476− Just (FanSubscribedChildren list weakSelf) -> WeakBag.insert sub list weakSelf cleanupFanSubscribed
1477−
1478−{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1479−getSwitchSubscribed :: (Defer SomeHoldInit m, Defer SomeAssignment m, Defer SomeMergeInit m, Defer SomeClear m, Defer SomeResetCoincidence m, HasCurrentHeight m, HasSpiderEnv x m) => Switch a -> Subscriber a -> m (SubscriberListTicket a, SwitchSubscribed a)
1480−getSwitchSubscribed s sub = do
1481− mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1482− case mSubscribed of
1483− Just subscribed -> {-# SCC "hitSwitch" #-} do
1484− sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1485− return (sln, subscribed)
1486− Nothing -> {-# SCC "missSwitch" #-} do
1487− subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1488− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1489− i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1490− mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1491− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1492− wiRef <- liftIO $ newIORef wi
1493− parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1494− holdInits <- getDeferralQueue
1495− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1496− subscription@(_, subd) <- subscribe e mySub
1497− subscriptionRef <- liftIO $ newIORef subscription
1498− parentOcc <- liftIO $ readEventSubscribed subd
1499− occRef <- liftIO $ newIORef parentOcc
1500− when (isJust parentOcc) $ scheduleClear occRef
1501− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
1502− weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1503− (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1504− let !subscribed = SwitchSubscribed
1505− { switchSubscribedCachedSubscribed = switchSubscribed s
1506− , switchSubscribedOccurrence = occRef
1507− , switchSubscribedHeight = heightRef
1508− , switchSubscribedSubscribers = subs
1509− , switchSubscribedOwnInvalidator = i
1510− , switchSubscribedOwnWeakInvalidator = wiRef
1511− , switchSubscribedBehaviorParents = parentsRef
1512− , switchSubscribedParent = switchParent s
1513− , switchSubscribedCurrentParent = subscriptionRef
1514− , switchSubscribedWeakSelf = weakSelf
1515−#ifdef DEBUG_NODEIDS
1516− , switchSubscribedNodeId = unsafeNodeId s
1517−#endif
1518− }
1519− liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1520− liftIO $ writeIORef subscribedRef subscribed
1521− liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1522− return (slnForSub, subscribed)
1523−
1524−cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1525−cleanupSwitchSubscribed subscribed = do
1526− unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1527− finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1528− writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1529−
1530−{-# INLINE subscribeSwitchSubscribed #-}
1531−subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1532−subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1533−
1534−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1535−getCoincidenceSubscribed :: forall x a m. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Coincidence a -> Subscriber a -> m (SubscriberListTicket a, CoincidenceSubscribed a)
1536−getCoincidenceSubscribed c sub = do
1537− mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1538− case mSubscribed of
1539− Just subscribed -> {-# SCC "hitCoincidence" #-} do
1540− sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1541− return (sln, subscribed)
1542− Nothing -> {-# SCC "missCoincidence" #-} do
1543− subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1544− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1545− subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1546− outerSubscription@(_, outerSubd) <- subscribe (coincidenceParent c) subOuter
1547− outerOcc <- liftIO $ readEventSubscribed outerSubd
1548− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1549− (occ, height, mInnerSubd) <- case outerOcc of
1550− Nothing -> return (Nothing, outerHeight, Nothing)
1551− Just o -> do
1552− (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1553− return (occ, height, Just innerSubd)
1554− occRef <- liftIO $ newIORef occ
1555− when (isJust occ) $ scheduleClear occRef
1556− heightRef <- liftIO $ newIORef height
1557− innerSubdRef <- liftIO $ newIORef mInnerSubd
1558− scheduleClear innerSubdRef
1559− weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1560− (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1561− let subscribed = CoincidenceSubscribed
1562− { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1563− , coincidenceSubscribedOccurrence = occRef
1564− , coincidenceSubscribedHeight = heightRef
1565− , coincidenceSubscribedSubscribers = subs
1566− , coincidenceSubscribedOuter = subOuter
1567− , coincidenceSubscribedOuterParent = outerSubscription
1568− , coincidenceSubscribedInnerParent = innerSubdRef
1569− , coincidenceSubscribedWeakSelf = weakSelf
1570−#ifdef DEBUG_NODEIDS
1571− , coincidenceSubscribedNodeId = unsafeNodeId c
1572−#endif
1573− }
1574− liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1575− liftIO $ writeIORef subscribedRef subscribed
1576− liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1577− return (slnForSub, subscribed)
1578−
1579−cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1580−cleanupCoincidenceSubscribed subscribed = do
1581− unsubscribe $ coincidenceSubscribedOuterParent subscribed
1582− writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1583−
1584−{-# INLINE subscribeCoincidenceSubscribed #-}
1585−subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1586−subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1587−
1588−{-# INLINE merge #-}
1589−merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
1590−merge m = EventMerge $ Merge
1591− { mergeParents = m
1592− , mergeSubscribed = unsafeNewIORef m Nothing
1593− }
1594−
1595−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1596−
1597−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1598−fan e =
1599− let f = Fan
1600− { fanParent = e
1601− , fanSubscribed = unsafeNewIORef e Nothing
1602− }
1603− in EventSelector $ \k -> EventFan k f
1604−
1605−{- SPECIALIZE runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x () #-}
1606−--runHoldInits :: (CanSubscribe x m, Defer SomeMergeUpdate m) => IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> m ()
1607−runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1608−runHoldInits holdInitRef mergeInitRef = do
1609− holdInits <- liftIO $ readIORef holdInitRef
1610− mergeInits <- liftIO $ readIORef mergeInitRef
1611− if null holdInits && null mergeInits then return () else do
1612− liftIO $ writeIORef holdInitRef []
1613− liftIO $ writeIORef mergeInitRef []
1614− mapM_ initHold holdInits
1615− mapM_ initMerge mergeInits
1616− runHoldInits holdInitRef mergeInitRef
1617−
1618−{- SPECIALIZE initHold :: SomeHoldInit -> EventM x () #-}
1619−--initHold :: CanSubscribe x m => SomeHoldInit -> m ()
1620−initHold :: SomeHoldInit -> EventM x ()
1621−initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1622−
1623−{- SPECIALIZE initMerge :: SomeMergeInit -> EventM x () #-}
1624−--initMerge :: (CanSubscribe x m, Defer SomeMergeUpdate m) => SomeMergeInit -> m ()
1625−initMerge :: SomeMergeInit -> EventM x ()
1626−initMerge (SomeMergeInit subscribed changed) = do
1627− changeSub <- liftIO $ newSubscriberMergeChange subscribed
1628− (_, changeSubd) <- subscribe changed changeSub
1629− change <- liftIO $ readEventSubscribed changeSubd
1630− forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1631− liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
1632−
1633−-- | Run an event action outside of a frame
1634−runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1635−runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1636− -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now
1637− pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)
1638− {-# SCC "cleanups" #-} sequence_ pendingCleanups
1639− toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1640− holdInitRef <- newIORef []
1641− mergeUpdateRef <- newIORef []
1642− mergeInitRef <- newIORef []
1643− heightRef <- newIORef zeroHeight
1644− toClearRef <- newIORef []
1645− toClearRootRef <- newIORef []
1646− coincidenceInfosRef <- newIORef []
1647− delayedRef <- liftIO $ newIORef IntMap.empty
1648− let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1649− let go = do
1650− result <- a
1651− runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1652− return result
1653− result <- runEventM go env
1654− toClear <- readIORef toClearRef
1655− forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1656− toClearRoot <- readIORef toClearRootRef
1657− forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref DMap.empty
1658− toAssign <- readIORef toAssignRef
1659− toReconnectRef <- newIORef []
1660− coincidenceInfos <- readIORef coincidenceInfosRef
1661− forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1662− writeIORef vRef v
1663− when debugInvalidate $ putStrLn $ "Invalidating Hold"
1664− writeIORef iRef =<< invalidate toReconnectRef =<< readIORef iRef
1665− mergeUpdates <- readIORef mergeUpdateRef
1666− writeIORef mergeUpdateRef []
1667− let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1668− updateMerge (SomeMergeUpdate (R.PatchDMap p) m) = do
1669− oldParents <- readIORef $ mergeSubscribedParents m
1670− let f (subscriptionsToKill, ps) (k :=> Compose me) = do
1671− (mOldSubd, newPs) <- case me of
1672− Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1673− Just e -> do
1674− s <- liftIO $ newSubscriberMerge k m
1675− subscription <- subscribe e s
1676− let newParent = MergeSubscribedParent subscription s
1677− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1678− liftIO $ invalidateMergeHeight k m
1679− return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1680− (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1681− writeIORef (mergeSubscribedParents m) $! newParents
1682− return subscriptionsToKill
1683− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1684− toReconnect <- readIORef toReconnectRef
1685− switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1686− oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1687− wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1688− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
1689− finalize wi
1690− i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1691− wi' <- mkWeakPtrWithDebug i "wi'"
1692− writeIORef (switchSubscribedOwnWeakInvalidator subscribed) wi'
1693− writeIORef (switchSubscribedBehaviorParents subscribed) []
1694− writeIORef holdInitRef [] --TODO: Should we reuse this?
1695− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1696− runEventM (runHoldInits holdInitRef mergeInitRef) 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
1697− --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1698− sub <- newSubscriberSwitch subscribed
1699− subscription@(_, subd') <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --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
1700− {-
1701− stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1702− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1703− EventRoot _ -> "EventRoot"
1704− EventNever -> "EventNever"
1705− _ -> "something else"
1706− -}
1707− writeIORef (switchSubscribedCurrentParent subscribed) subscription
1708− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1709− myHeight <- readIORef $ switchSubscribedHeight subscribed
1710− when (parentHeight /= myHeight) $ do
1711− writeIORef (switchSubscribedHeight subscribed) parentHeight
1712− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1713− return $ SomeEventSubscription oldSubscription
1714− forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1715− unsubscribe subscription
1716− mapM_ invalidateCoincidenceHeight mcs
1717− forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1718− forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1719− forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1720− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> recalculateMergeHeight m
1721− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1722− WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1723− return result
1724−
1725−newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1726−
1727−{-# INLINE zeroHeight #-}
1728−zeroHeight :: Height
1729−zeroHeight = Height 0
1730−
1731−{-# INLINE invalidHeight #-}
1732−invalidHeight :: Height
1733−invalidHeight = Height (-1000)
1734−
1735−-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1736−{-# INLINE invalidHeightBeingTraversed #-}
1737−invalidHeightBeingTraversed :: Height
1738−invalidHeightBeingTraversed = Height (-1001)
1739−
1740−{-# INLINE succHeight #-}
1741−succHeight :: Height -> Height
1742−succHeight h@(Height a) =
1743− if h == invalidHeight
1744− then invalidHeight
1745− else Height $ succ a
1746−
1747−-- Get the maximum height; if either of the inputs is invalid, the output will also be invalid
1748−{-# INLINE maxHeight #-}
1749−maxHeight :: Height -> Height -> Height
1750−maxHeight ha@(Height a) hb@(Height b) =
1751− if ha == invalidHeight || hb == invalidHeight
1752− then invalidHeight
1753− else Height $ max a b
1754−
1755−invalidateSubscriberHeight :: Subscriber a -> IO ()
1756−invalidateSubscriberHeight s = case s of
1757− SubscriberPush _ subscribed -> do
1758− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1759− WeakBag.traverse (pushSubscribedSubscribers subscribed) invalidateSubscriberHeight
1760− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1761− SubscriberMerge k subscribed -> do
1762− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1763− invalidateMergeHeight k subscribed
1764− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1765− SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
1766− SubscriberFan subscribed -> do
1767− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1768− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1769− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) invalidateSubscriberHeight
1770− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1771− SubscriberHold _ -> return ()
1772− SubscriberHoldIdentity _ -> return ()
1773− SubscriberSwitch subscribed -> do
1774− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1775− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1776− when (oldHeight /= invalidHeight) $ do
1777− writeIORef (switchSubscribedHeight subscribed) invalidHeight
1778− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1779− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1780− SubscriberCoincidenceOuter subscribed -> do
1781− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1782− invalidateCoincidenceHeight subscribed
1783− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1784− SubscriberCoincidenceInner subscribed -> do
1785− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1786− invalidateCoincidenceHeight subscribed
1787− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1788− SubscriberHandle -> return ()
1789−
1790−--TODO: Actually use the key
1791−invalidateMergeHeight :: k a -> MergeSubscribed k -> IO ()
1792−invalidateMergeHeight _ subscribed = do
1793− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1794− when (oldHeight /= invalidHeight) $ do
1795− writeIORef (mergeSubscribedHeight subscribed) invalidHeight
1796− WeakBag.traverse (mergeSubscribedSubscribers subscribed) invalidateSubscriberHeight
1797−
1798−recalculateMergeHeight :: MergeSubscribed k -> IO ()
1799−recalculateMergeHeight subscribed = do
1800− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1801− when (oldHeight == invalidHeight) $ do
1802− height <- calculateMergeHeight subscribed
1803− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1804− when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1805− writeIORef (mergeSubscribedHeight subscribed) height
1806− WeakBag.traverse (mergeSubscribedSubscribers subscribed) recalculateSubscriberHeight
1807−
1808−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1809−invalidateCoincidenceHeight subscribed = do
1810− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1811− when (oldHeight /= invalidHeight) $ do
1812− writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight
1813− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
1814−
1815−--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1816−
1817−recalculateSubscriberHeight :: Subscriber a -> IO ()
1818−recalculateSubscriberHeight s = case s of
1819− SubscriberPush _ subscribed -> do
1820− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1821− WeakBag.traverse (pushSubscribedSubscribers subscribed) recalculateSubscriberHeight
1822− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1823− SubscriberMerge _ subscribed -> do
1824− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1825− recalculateMergeHeight subscribed
1826− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1827− SubscriberMergeChange _ -> return ()
1828− SubscriberFan subscribed -> do
1829− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1830− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1831− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) recalculateSubscriberHeight
1832− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1833− SubscriberHold _ -> return ()
1834− SubscriberHoldIdentity _ -> return ()
1835− SubscriberSwitch subscribed -> do
1836− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1837− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1838− when (oldHeight == invalidHeight) $ do
1839− height <- calculateSwitchHeight subscribed
1840− when (height /= invalidHeight) $ do
1841− writeIORef (switchSubscribedHeight subscribed) height
1842− WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1843− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1844− SubscriberCoincidenceOuter subscribed -> do
1845− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1846− recalculateCoincidenceHeight subscribed
1847− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1848− SubscriberCoincidenceInner subscribed -> do
1849− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1850− recalculateCoincidenceHeight subscribed
1851− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1852− SubscriberHandle -> return ()
1853−
1854−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1855−recalculateCoincidenceHeight subscribed = do
1856− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1857− when (oldHeight == invalidHeight) $ do
1858− height <- calculateCoincidenceHeight subscribed
1859− when (height /= invalidHeight) $ do
1860− writeIORef (coincidenceSubscribedHeight subscribed) height
1861− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight --TODO: This should probably be mandatory, just like with the merge and switch ones
1862−
1863−calculateMergeHeight :: MergeSubscribed k -> IO Height
1864−calculateMergeHeight subscribed = do
1865− parents <- readIORef $ mergeSubscribedParents subscribed
1866− if DMap.null parents then return zeroHeight else do
1867− heights <- forM (DMap.toList parents) $ \(_ :=> es) -> do
1868− readIORef $ eventSubscribedHeightRef $ snd $ mergeSubscribedParentSubscription es
1869− return $ succHeight $ foldr maxHeight zeroHeight heights
1870−
1871−calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1872−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . snd =<< readIORef (switchSubscribedCurrentParent subscribed)
1873−
1874−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1875−calculateCoincidenceHeight subscribed = do
1876− outerHeight <- readIORef $ eventSubscribedHeightRef $ snd $ coincidenceSubscribedOuterParent subscribed
1877− innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1878− return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1879−
1880−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1881−
1882−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1883−invalidate toReconnectRef wis = do
1884− forM_ wis $ \wi -> do
1885− mi <- deRefWeak wi
1886− case mi of
1887− Nothing -> do
1888− traceInvalidate "invalidate Dead"
1889− return () --TODO: Should we clean this up here?
1890− Just i -> do
1891− finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1892− case i of
1893− InvalidatorPull p -> do
1894− traceInvalidate $ "invalidate: Pull" <> showNodeId p
1895− mVal <- readIORef $ pullValue p
1896− forM_ mVal $ \val -> do
1897− writeIORef (pullValue p) Nothing
1898− writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1899− InvalidatorSwitch subscribed -> do
1900− traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
1901− modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1902− 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
1903−
1904−--------------------------------------------------------------------------------
1905−-- Reflex integration
1906−--------------------------------------------------------------------------------
1907−
1908−type Spider = SpiderEnv Global
1909−
1910−data Global
1911−
1912−{-# NOINLINE globalSpiderEnv #-}
1913−globalSpiderEnv :: SpiderEnv Global
1914−globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv
1915−
1916−type role SpiderEnv nominal
1917−data SpiderEnv x = SpiderEnv
1918− { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])
1919− , _spiderEnv_lock :: !(MVar ())
1920− , _spiderEnv_cleanups :: !(IORef [IO ()])
1921−#ifdef DEBUG
1922− , _spiderEnv_depth :: !(IORef Int)
1923−#endif
1924− }
1925−
1926−instance GEq SpiderEnv where
1927− a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
1928− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments
1929− else Nothing
1930−
1931−unsafeNewSpiderEnv :: forall x. IO (SpiderEnv x)
1932−unsafeNewSpiderEnv = do
1933− toUnsubscribe <- newIORef []
1934− lock <- newMVar ()
1935− cleanups <- newIORef []
1936−#ifdef DEBUG
1937− depthRef <- newIORef 0
1938−#endif
1939− return $ SpiderEnv
1940− { _spiderEnv_toUnsubscribe = toUnsubscribe
1941− , _spiderEnv_lock = lock
1942− , _spiderEnv_cleanups = cleanups
1943−#ifdef DEBUG
1944− , _spiderEnv_depth = depthRef
1945−#endif
1946− }
1947−
1948−newSpiderEnv :: IO (Some SpiderEnv)
1949−newSpiderEnv = Some.This <$> unsafeNewSpiderEnv
1950−
1951−newtype SpiderPullM x a = SpiderPullM { runSpiderPullM :: BehaviorM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1952−
1953−newtype SpiderPushM x a = SpiderPushM { runSpiderPushM :: ComputeM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1954−
1955−instance R.Reflex (SpiderEnv x) where
1956− newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1957− newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event a }
1958− newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
1959− newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
1960− type PullM (SpiderEnv x) = SpiderPullM x
1961− type PushM (SpiderEnv x) = SpiderPushM x
1962− {-# INLINABLE never #-}
1963− never = SpiderEvent EventNever
1964− {-# INLINABLE constant #-}
1965− constant = SpiderBehavior . BehaviorConst
1966− {-# INLINABLE push #-}
1967− push f = SpiderEvent . push (coerce f) . unSpiderEvent
1968− {-# INLINABLE pull #-}
1969− pull = SpiderBehavior . pull . coerce
1970− {-# INLINABLE merge #-}
1971− merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k Event)
1972− {-# INLINABLE fan #-}
1973− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1974− {-# INLINABLE switch #-}
1975− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderEnv x) a) -> Behavior (Event a)) . unSpiderBehavior
1976− {-# INLINABLE coincidence #-}
1977− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderEnv x) a) -> Event (Event a)) . unSpiderEvent
1978− {-# INLINABLE current #-}
1979− current = SpiderBehavior . current . unSpiderDynamic
1980− {-# INLINABLE updated #-}
1981− updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
1982− {-# INLINABLE unsafeBuildDynamic #-}
1983− unsafeBuildDynamic readV0 v' = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (coerce readV0) $ addIdentity $ unSpiderEvent v'
1984− {-# INLINABLE unsafeBuildIncremental #-}
1985− unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1986− {-# INLINABLE mergeIncremental #-}
1987− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental
1988− {-# INLINABLE currentIncremental #-}
1989− currentIncremental = SpiderBehavior . current . unSpiderIncremental
1990− {-# INLINABLE updatedIncremental #-}
1991− updatedIncremental = SpiderEvent . updated . unSpiderIncremental
1992− {-# INLINABLE incrementalToDynamic #-}
1993− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
1994− c <- readBehaviorUntracked $ current i
1995− return $ fmap Identity $ R.apply p c --TODO: Avoid the redundant 'apply'
1996−
1997−instance R.MonadSample (SpiderEnv x) (EventM x) where
1998− {-# INLINABLE sample #-}
1999− sample (SpiderBehavior b) = readBehaviorUntracked b
2000−
2001−instance R.MonadHold (SpiderEnv x) (EventM x) where
2002− {-# INLINABLE hold #-}
2003− hold = holdSpiderEventM
2004− {-# INLINABLE holdDyn #-}
2005− holdDyn = holdDynSpiderEventM
2006− {-# INLINABLE holdIncremental #-}
2007− holdIncremental = holdIncrementalSpiderEventM
2008−
2009−holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)
2010−holdSpiderEventM v0 e = liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2011−
2012−holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)
2013−holdDynSpiderEventM v0 e = liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2014−
2015−holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)
2016−holdIncrementalSpiderEventM v0 e = liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2017−
2018−instance R.MonadHold (SpiderEnv x) (SpiderHost x) where
2019− {-# INLINABLE hold #-}
2020− hold v0 e = R.runHostFrame $ R.hold v0 e
2021− {-# INLINABLE holdDyn #-}
2022− holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
2023− {-# INLINABLE holdIncremental #-}
2024− holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
2025−
2026−instance R.MonadSample (SpiderEnv x) (SpiderHost x) where
2027− {-# INLINABLE sample #-}
2028− sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2029−
2030−instance R.MonadSample (SpiderEnv x) (SpiderPullM x) where
2031− {-# INLINABLE sample #-}
2032− sample = coerce . readBehaviorTracked . unSpiderBehavior
2033−
2034−instance R.MonadSample (SpiderEnv x) (SpiderPushM x) where
2035− {-# INLINABLE sample #-}
2036− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2037−
2038−instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where
2039− {-# INLINABLE hold #-}
2040− hold v0 e = R.current <$> R.holdDyn v0 e
2041− {-# INLINABLE holdDyn #-}
2042− holdDyn v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e
2043− {-# INLINABLE holdIncremental #-}
2044− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderIncremental . DynamicHold) $ hold v0 e
2045−
2046−data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
2047−newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
2048−
2049−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where
2050− {-# INLINABLE subscribeEvent #-}
2051− subscribeEvent e = SpiderHostFrame $ do
2052− subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2053− return $ SpiderEventHandle subscription
2054−
2055−instance R.ReflexHost (SpiderEnv x) where
2056− type EventTrigger (SpiderEnv x) = RootTrigger
2057− type EventHandle (SpiderEnv x) = SpiderEventHandle
2058− type HostFrame (SpiderEnv x) = SpiderHostFrame x
2059−
2060−instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
2061− {-# INLINABLE readEvent #-}
2062− readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do
2063− let (sln, subscribed) = unSpiderEventHandle h
2064− result <- readEventSubscribed subscribed
2065− touch sln
2066− return result
2067−
2068−instance MonadRef (EventM x) where
2069− type Ref (EventM x) = Ref IO
2070− {-# INLINABLE newRef #-}
2071− {-# INLINABLE readRef #-}
2072− {-# INLINABLE writeRef #-}
2073− newRef = liftIO . newRef
2074− readRef = liftIO . readRef
2075− writeRef r a = liftIO $ writeRef r a
2076−
2077−instance MonadAtomicRef (EventM x) where
2078− {-# INLINABLE atomicModifyRef #-}
2079− atomicModifyRef r f = liftIO $ atomicModifyRef r f
2080−
2081−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2082−
2083−instance Monad (SpiderHost x) where
2084− {-# INLINABLE (>>=) #-}
2085− SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2086− {-# INLINABLE (>>) #-}
2087− SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2088− {-# INLINABLE return #-}
2089− return x = SpiderHost $ return x
2090− {-# INLINABLE fail #-}
2091− fail s = SpiderHost $ fail s
2092−
2093−runSpiderHost :: SpiderHost Global a -> IO a
2094−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderEnv
2095−
2096−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2097−
2098−instance Monad (SpiderHostFrame x) where
2099− {-# INLINABLE (>>=) #-}
2100− SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2101− {-# INLINABLE (>>) #-}
2102− SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2103− {-# INLINABLE return #-}
2104− return x = SpiderHostFrame $ return x
2105− {-# INLINABLE fail #-}
2106− fail s = SpiderHostFrame $ fail s
2107−
2108−instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where
2109− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2110−
2111−addIdentity :: Event a -> Event (Identity a)
2112−--addIdentity = fmap Identity
2113−addIdentity = unsafeCoerce
2114−
2115−instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where
2116− {-# INLINABLE hold #-}
2117− hold v0 e = SpiderHostFrame $ liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2118− {-# INLINABLE holdDyn #-}
2119− holdDyn v0 e = SpiderHostFrame $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2120− {-# INLINABLE holdIncremental #-}
2121− holdIncremental v0 e = SpiderHostFrame $ liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2122−
2123−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
2124−newEventWithTriggerIO f = do
2125− es <- newFanEventWithTriggerIO $ \Refl -> f
2126− return $ select es Refl
2127−
2128−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
2129−newFanEventWithTriggerIO f = do
2130− occRef <- newIORef DMap.empty
2131− subscribedRef <- newIORef DMap.empty
2132− let !r = Root
2133− { rootOccurrence = occRef
2134− , rootSubscribed = subscribedRef
2135− , rootInit = f
2136− }
2137− return $ EventSelector $ \k -> EventRoot k r
2138−
2139−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where
2140− newEventWithTrigger = SpiderHost . lift . liftM SpiderEvent . newEventWithTriggerIO
2141− newFanEventWithTrigger f = SpiderHost $ lift $ do
2142− es <- newFanEventWithTriggerIO f
2143− return $ R.EventSelector $ SpiderEvent . select es
2144−
2145−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where
2146− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
2147− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2148− es <- newFanEventWithTriggerIO f
2149− return $ R.EventSelector $ SpiderEvent . select es
2150−
2151−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where
2152− {-# INLINABLE subscribeEvent #-}
2153− subscribeEvent = subscribeEventSpiderHost
2154−
2155−subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)
2156−subscribeEventSpiderHost e = do
2157− subscription <- runFrame $ getEventSubscribed (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2158− return $ SpiderEventHandle subscription
2159−
2160−newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)
2161−
2162−instance R.MonadSample (SpiderEnv x) (ReadPhase x) where
2163− {-# INLINABLE sample #-}
2164− sample = ReadPhase . R.sample
2165−
2166−instance R.MonadHold (SpiderEnv x) (ReadPhase x) where
2167− {-# INLINABLE hold #-}
2168− hold v0 e = ReadPhase $ R.hold v0 e
2169− {-# INLINABLE holdDyn #-}
2170− holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2171− {-# INLINABLE holdIncremental #-}
2172− holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
2173−
2174−instance R.MonadReflexHost (SpiderEnv x) (SpiderHost x) where
2175− type ReadPhase (SpiderHost x) = ReadPhase x
2176− fireEventsAndRead es (ReadPhase a) = run es a
2177− runHostFrame = runFrame . runSpiderHostFrame
2178−
2179−instance MonadRef (SpiderHost x) where
2180− type Ref (SpiderHost x) = Ref IO
2181− newRef = SpiderHost . newRef
2182− readRef = SpiderHost . readRef
2183− writeRef r = SpiderHost . writeRef r
2184−
2185−instance MonadAtomicRef (SpiderHost x) where
2186− atomicModifyRef r = SpiderHost . atomicModifyRef r
2187−
2188−instance MonadRef (SpiderHostFrame x) where
2189− type Ref (SpiderHostFrame x) = Ref IO
2190− newRef = SpiderHostFrame . newRef
2191− readRef = SpiderHostFrame . readRef
2192− writeRef r = SpiderHostFrame . writeRef r
2193−
2194−instance MonadAtomicRef (SpiderHostFrame x) where
2195− atomicModifyRef r = SpiderHostFrame . atomicModifyRef r