@@ -1,2267 +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, MultiWayIf #-}
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.Strict (IntMap)
26−import qualified Data.IntMap.Strict 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@(EventSubscription _ 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 HeightBag = HeightBag
413− { _heightBag_size :: {-# UNPACK #-} !Int
414− , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
415− }
416− deriving (Show, Read, Eq, Ord)
417−
418−heightBagEmpty :: HeightBag
419−heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
420−
421−heightBagSize :: HeightBag -> Int
422−heightBagSize = _heightBag_size
423−
424−heightBagFromList :: [Height] -> HeightBag
425−heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
426−
427−heightBagAdd :: Height -> HeightBag -> HeightBag
428−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
429−
430−heightBagRemove :: Height -> HeightBag -> HeightBag
431−heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
432− Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
433− Just old -> HeightBag (pred s) $ case old of
434− 0 -> IntMap.delete h c
435− _ -> IntMap.insert h (pred old) c
436−
437−heightBagMax :: HeightBag -> Height
438−heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
439− Just ((h, _), _) -> Height h
440− Nothing -> zeroHeight
441−
442−heightBagVerify :: HeightBag -> HeightBag
443−#ifdef DEBUG
444−heightBagVerify b@(HeightBag s c) = if
445− | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
446− -> error $ "heightBagVerify: size doesn't match: " <> show b
447− | unHeight invalidHeight `IntMap.member` c
448− -> error $ "heightBagVerify: contains invalid height: " <> show b
449− | otherwise -> b
450−#else
451−heightBagVerify = id
452−#endif
453−
454−data MergeSubscribed k
455− = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
456− , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
457− , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
458− , mergeSubscribedHeight :: !(IORef Height)
459− , mergeSubscribedHeightBag :: !(IORef HeightBag)
460− , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
461− , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
462− , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
463− , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))
464−#ifdef DEBUG_NODEIDS
465− , mergeSubscribedNodeId :: Int
466−#endif
467− }
468−
469−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
470−data Merge k
471− = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
472− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
473− }
474−
475−data FanSubscribedChildren k a = FanSubscribedChildren
476− { _fanSubscribedChildren_list :: !(SubscriberList a)
477− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed k)
478− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
479− }
480−
481−data FanSubscribed k
482− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
483− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
484− , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
485−#ifdef DEBUG_NODEIDS
486− , fanSubscribedNodeId :: Int
487−#endif
488− }
489−
490−data Fan k
491− = Fan { fanParent :: !(Event (DMap k Identity))
492− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
493− }
494−
495−data SwitchSubscribed a
496− = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
497− , switchSubscribedOccurrence :: !(IORef (Maybe a))
498− , switchSubscribedHeight :: !(IORef Height)
499− , switchSubscribedSubscribers :: !(SubscriberList a)
500− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
501− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
502− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
503− , switchSubscribedParent :: !(Behavior (Event a))
504− , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
505− , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
506−#ifdef DEBUG_NODEIDS
507− , switchSubscribedNodeId :: Int
508−#endif
509− }
510−
511−data Switch a
512− = Switch { switchParent :: !(Behavior (Event a))
513− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
514− }
515−
516−data CoincidenceSubscribed a
517− = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
518− , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
519− , coincidenceSubscribedSubscribers :: !(SubscriberList a)
520− , coincidenceSubscribedHeight :: !(IORef Height)
521− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
522− , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
523− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
524− , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
525−#ifdef DEBUG_NODEIDS
526− , coincidenceSubscribedNodeId :: Int
527−#endif
528− }
529−
530−data Coincidence a
531− = Coincidence { coincidenceParent :: !(Event (Event a))
532− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
533− }
534−
535−data Subscriber a
536− = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?
537− | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
538− | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)
539− | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
540− | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)
541− | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)
542− | SubscriberSwitch (SwitchSubscribed a)
543− | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
544− | SubscriberCoincidenceInner (CoincidenceSubscribed a)
545− | SubscriberHandle
546−
547−showSubscriberType :: Subscriber a -> String
548−showSubscriberType = \case
549− SubscriberPush _ _ -> "SubscriberPush"
550− SubscriberMerge _ _ -> "SubscriberMerge"
551− SubscriberFan _ -> "SubscriberFan"
552− SubscriberMergeChange _ -> "SubscriberMergeChange"
553− SubscriberHold _ -> "SubscriberHold"
554− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
555− SubscriberSwitch _ -> "SubscriberSwitch"
556− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
557− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
558− SubscriberHandle -> "SubscriberHandle"
559−
560−data Event a
561− = forall k. GCompare k => EventRoot !(k a) !(Root k)
562− | EventNever
563− | forall b. EventPush !(Push b a)
564− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
565− | forall k. GCompare k => EventFan !(k a) !(Fan k)
566− | EventSwitch !(Switch a)
567− | EventCoincidence !(Coincidence a)
568− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
569− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
570− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
571− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
572−
573−showEventType :: Event a -> String
574−showEventType = \case
575− EventRoot _ _ -> "EventRoot"
576− EventNever -> "EventNever"
577− EventPush _ -> "EventPush"
578− EventMerge _ -> "EventMerge"
579− EventFan _ _ -> "EventFan"
580− EventSwitch _ -> "EventSwitch"
581− EventCoincidence _ -> "EventCoincidence"
582− EventHold _ -> "EventHold"
583− EventDyn _ -> "EventDyn"
584− EventHoldIdentity _ -> "EventHoldIdentity"
585− EventDynIdentity _ -> "EventDynIdentity"
586−
587−data EventSubscription a = EventSubscription
588− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
589− , _eventSubscription_subscribed :: !(EventSubscribed a)
590− }
591−
592−data EventSubscribed a
593− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
594− | EventSubscribedNever
595− | forall b. EventSubscribedPush !(PushSubscribed b a)
596− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
597− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
598− | EventSubscribedSwitch !(SwitchSubscribed a)
599− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
600−
601−unsubscribe :: EventSubscription a -> IO ()
602−unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
603−
604−-- These function are constructor functions that are marked NOINLINE so they are
605−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
606−-- so any weak references that are attached to the constructors will have their
607−-- finalizer run. Using the opaque constructor, does not see the
608−-- constructor application, so it behaves like an IORef and cannot be fused away.
609−--
610−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
611−-- the weak pointer to it in some cases.
612−
613−--TODO: I think all of these noinlines are now unnecessary
614−{-# NOINLINE newSubscriberPush #-}
615−newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
616−newSubscriberPush compute subd = return $! SubscriberPush compute subd
617−
618−{-# RULES
619− "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
620− #-}
621−{-# NOINLINE newSubscriberHold #-}
622−newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
623−newSubscriberHold h = return $! SubscriberHold h
624−
625−{-# NOINLINE newSubscriberHoldIdentity #-}
626−newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
627−newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
628−
629−{-# NOINLINE newSubscriberMerge #-}
630−newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
631−newSubscriberMerge k subd = return $! SubscriberMerge k subd
632−
633−{-# NOINLINE newSubscriberMergeChange #-}
634−newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
635−newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
636−
637−{-# NOINLINE newSubscriberFan #-}
638−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
639−newSubscriberFan subd = return $! SubscriberFan subd
640−
641−{-# NOINLINE newSubscriberSwitch #-}
642−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
643−newSubscriberSwitch subd = return $! SubscriberSwitch subd
644−
645−{-# NOINLINE newSubscriberCoincidenceOuter #-}
646−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
647−newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
648−
649−{-# NOINLINE newSubscriberCoincidenceInner #-}
650−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
651−newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
652−
653−{-# NOINLINE newInvalidatorSwitch #-}
654−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
655−newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
656−
657−{-# NOINLINE newInvalidatorPull #-}
658−newInvalidatorPull :: Pull a -> IO Invalidator
659−newInvalidatorPull p = return $! InvalidatorPull p
660−
661−data Dynamic p a
662− = DynamicHold !(Hold p a)
663− | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
664− | DynamicConst !a
665− | DynamicDyn !(Dyn p a)
666− | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
667−
668−{-# INLINE current #-}
669−current :: R.Patch p => Dynamic p a -> Behavior a
670−current = \case
671− DynamicHold h -> BehaviorHold h
672− DynamicHoldIdentity h -> BehaviorHoldIdentity h
673− DynamicConst a -> BehaviorConst a
674− DynamicDyn d -> BehaviorDyn d
675− DynamicDynIdentity d -> BehaviorDynIdentity d
676−
677−--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
678−{-# INLINE updated #-}
679−updated :: R.Patch p => Dynamic p a -> Event (p a)
680−updated = \case
681− DynamicHold h -> EventHold h
682− DynamicHoldIdentity h -> EventHoldIdentity h
683− DynamicConst _ -> EventNever
684− DynamicDyn d -> EventDyn d
685− DynamicDynIdentity d -> EventDynIdentity d
686−
687−newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b
688−newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (fmap (Identity . f . runIdentity) $ updated d)
689−
690−instance Functor (Dynamic Identity) where
691− fmap f d = newMapDyn f d
692−
693−instance Applicative (Dynamic Identity) where
694− pure = DynamicConst
695− (<*>) = zipDynWith ($)
696− _ *> b = b
697− a <* _ = a
698−
699−instance R.FunctorMaybe Event where
700− fmapMaybe f = push $ return . f
701−
702−instance Align Event where
703− nil = EventNever
704− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
705−
706−--TODO: Avoid the duplication between this and R.zipDynWith
707−zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c
708−zipDynWith f da db =
709− let eab = align (updated da) (updated db)
710− ec = flip push eab $ \o -> do
711− (a, b) <- case o of
712− This (Identity a) -> do
713− b <- readBehaviorUntracked $ current db
714− return (a, b)
715− That (Identity b) -> do
716− a <- readBehaviorUntracked $ current da
717− return (a, b)
718− These (Identity a) (Identity b) -> return (a, b)
719− return $ Just $ Identity $ f a b
720− in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec
721−
722−instance Monad (Dynamic Identity) where
723− {-# INLINE return #-}
724− return = pure
725− {-# INLINE (>>=) #-}
726− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
727− {-# INLINE (>>) #-}
728− _ >> y = y
729− {-# INLINE fail #-}
730− fail _ = error "Dynamic does not support 'fail'"
731−
732−newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
733−
734−unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
735−unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
736− where x = (readV0, v')
737−
738−newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
739−newJoinDyn d =
740− let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)
741− eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d
742− eInner = switch $ fmap updated $ current d
743− eBoth = coincidence $ fmap (updated . runIdentity) $ updated d
744− v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
745− in unsafeDyn readV0 v'
746−
747−--type role Behavior representational
748−data Behavior a
749− = forall p. BehaviorHold !(Hold p a)
750− | BehaviorHoldIdentity !(Hold Identity a)
751− | BehaviorConst !a
752− | BehaviorPull !(Pull a)
753− | BehaviorDynIdentity !(Dyn Identity a)
754− | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
755−
756−-- ResultM can read behaviors and events
757−type ResultM = EventM
758−
759−{-# NOINLINE unsafeNewIORef #-}
760−unsafeNewIORef :: a -> b -> IORef b
761−unsafeNewIORef _ b = unsafePerformIO $ newIORef b
762−
763−instance Functor Event where
764− fmap f = push $ return . Just . f
765−
766−instance Functor Behavior where
767− fmap f = pull . liftM f . readBehaviorTracked
768−
769−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
770−push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
771−push f e = EventPush $ Push
772− { pushCompute = f
773− , pushParent = e
774− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
775− }
776−-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
777−
778−{-# NOINLINE pull #-}
779−pull :: BehaviorM a -> Behavior a
780−pull a = BehaviorPull $ Pull
781− { pullCompute = a
782− , pullValue = unsafeNewIORef a Nothing
783−#ifdef DEBUG_NODEIDS
784− , pullNodeId = unsafeNodeId a
785−#endif
786− }
787−
788−{-# NOINLINE switch #-}
789−switch :: Behavior (Event a) -> Event a
790−switch a = EventSwitch $ Switch
791− { switchParent = a
792− , switchSubscribed = unsafeNewIORef a Nothing
793− }
794−
795−coincidence :: Event (Event a) -> Event a
796−coincidence a = EventCoincidence $ Coincidence
797− { coincidenceParent = a
798− , coincidenceSubscribed = unsafeNewIORef a Nothing
799− }
800−
801−propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
802−propagateAndUpdateSubscribersRef subscribersRef a = do
803− propagate a subscribersRef
804−
805−-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
806−run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b
807−run roots after = do
808− tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
809− spiderEnv <- SpiderHost ask
810− result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
811− rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
812− occBefore <- liftIO $ do
813− occBefore <- readIORef occRef
814− writeIORef occRef $! DMap.insert k a occBefore
815− return occBefore
816− if DMap.null occBefore
817− then do scheduleRootClear occRef
818− return $ Just r
819− else return Nothing
820− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
821− propagateAndUpdateSubscribersRef subscribersRef a
822− delayedRef <- EventM $ asks eventEnvDelayedMerges
823− let go = do
824− delayed <- liftIO $ readIORef delayedRef
825− case IntMap.minViewWithKey delayed of
826− Nothing -> return ()
827− Just ((currentHeight, cur), future) -> do
828− tracePropagate $ "Running height " ++ show currentHeight
829− putCurrentHeight $ Height currentHeight
830− liftIO $ writeIORef delayedRef $! future
831− forM_ cur $ \d -> case d of
832− DelayedMerge subscribed -> do
833− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
834− case height `compare` Height currentHeight of
835− LT -> error "Somehow a merge's height has been decreased after it was scheduled"
836− GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
837− EQ -> do
838− m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
839− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! DMap.empty
840− --TODO: Assert that m is not empty
841− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $! Just m
842− scheduleClear $ mergeSubscribedOccurrence subscribed
843− propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
844− go
845− go
846− putCurrentHeight maxBound
847− after
848− tracePropagate "Done running an event frame"
849− return result
850−
851−data SomeClear = forall a. SomeClear (IORef (Maybe a))
852−
853−data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
854−
855−data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
856−
857−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
858−
859−debugFinalize :: Bool
860−debugFinalize = False
861−
862−mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
863−mkWeakPtrWithDebug x debugNote = do
864− x' <- evaluate x
865− mkWeakPtr x' $
866− if debugFinalize
867− then Just $ putStrLn $ "finalizing: " ++ debugNote
868− else Nothing
869−
870−type WeakList a = [Weak a]
871−
872−{-# INLINE withIncreasedDepth #-}
873−#ifdef DEBUG
874−withIncreasedDepth :: CanTrace x m => m a -> m a
875−withIncreasedDepth a = do
876− spiderEnv <- askSpiderEnv
877− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
878− result <- a
879− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
880− return result
881−#else
882−withIncreasedDepth :: m a -> m a
883−withIncreasedDepth = id
884−#endif
885−
886−type CanTrace x m = (HasSpiderEnv x m, MonadIO m)
887−
888−{-# INLINE tracePropagate #-}
889−tracePropagate :: (CanTrace x m) => String -> m ()
890−tracePropagate = traceWhen debugPropagate
891−
892−{-# INLINE traceSubscribe #-}
893−traceSubscribe :: String -> IO ()
894−traceSubscribe = when debugSubscribe . liftIO . putStrLn
895−
896−{-# INLINE traceInvalidate #-}
897−traceInvalidate :: String -> IO ()
898−traceInvalidate = when debugInvalidate . liftIO . putStrLn
899−
900−{-# INLINE traceWhen #-}
901−traceWhen :: (CanTrace x m) => Bool -> String -> m ()
902−traceWhen b message = traceMWhen b $ return message
903−
904−{-# INLINE traceMWhen #-}
905−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
906−traceMWhen b getMessage = when b $ do
907− message <- getMessage
908−#ifdef DEBUG
909− spiderEnv <- askSpiderEnv
910− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
911−#else
912− let d = 0
913−#endif
914− liftIO $ putStrLn $ replicate d ' ' <> message
915−
916−whoCreatedIORef :: IORef a -> IO [String]
917−whoCreatedIORef (IORef a) = whoCreated $! a
918−
919−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
920−whoCreatedEventSubscribed = \case
921− EventSubscribedRoot _ -> return ["root"]
922− EventSubscribedNever -> return ["never"]
923− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
924− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
925− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
926− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
927− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
928−
929−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
930−walkInvalidHeightParents s0 = do
931− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
932− h <- liftIO $ readIORef $ eventSubscribedHeightRef s
933− when (h == invalidHeight) $ do
934− when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
935− modify (Some.This s :)
936− mapM_ loop =<< liftIO (eventSubscribedGetParents s)
937− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
938− return subscribers
939−
940−groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
941−groupByHead = \case
942− [] -> []
943− (x :| xs) : t -> case groupByHead t of
944− [] -> [(x, xs :| [])]
945− l@((y, yss) : t')
946− | x == y -> (x, xs `NonEmpty.cons` yss) : t'
947− | otherwise -> (x, xs :| []) : l
948−
949−listsToForest :: Eq a => [[a]] -> Forest a
950−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
951−
952−-- | Propagate everything at the current height
953−propagate :: a -> SubscriberList a -> EventM x ()
954−propagate a subscribers = withIncreasedDepth $ do
955− -- 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
956− --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
957− WeakBag.traverse subscribers $ \s -> case s of
958− SubscriberPush compute subscribed -> {-# SCC "traversePush" #-} do
959− tracePropagate $ "SubscriberPush" <> showNodeId subscribed
960− occ <- runComputeM $ compute a
961− case occ of
962− Nothing -> return () -- No need to write a Nothing back into the Ref
963− Just o -> do
964− liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
965− scheduleClear $ pushSubscribedOccurrence subscribed
966− propagate o $ pushSubscribedSubscribers subscribed
967− SubscriberMerge k subscribed -> {-# SCC "traverseMerge" #-} do
968− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
969− oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
970− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge" <> showNodeId subscribed) k (Identity a) oldM
971− tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
972− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! newM
973− when (DMap.null oldM) $ do -- Only schedule the firing once
974− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
975− --TODO: assertions about height
976− currentHeight <- getCurrentHeight
977− when (height <= currentHeight) $ do
978− myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
979− if height /= invalidHeight
980− then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
981− else liftIO $ do
982− nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
983− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
984− error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
985− scheduleMerge height subscribed
986− SubscriberMergeChange subscribed -> {-# SCC "traverseMergeChange" #-} do
987− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
988− defer $ SomeMergeUpdate a subscribed
989− SubscriberFan subscribed -> {-# SCC "traverseFan" #-} do
990− subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
991− tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
992− --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
993− forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
994− Nothing -> do
995− tracePropagate "No subscriber for key"
996− return ()
997− Just subsubs -> do
998− propagate v $ _fanSubscribedChildren_list subsubs
999− return ()
1000− SubscriberHold h -> {-# SCC "traverseHold" #-} propagateSubscriberHold h a
1001− SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a
1002− SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do
1003− tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
1004− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $! Just a
1005− scheduleClear $ switchSubscribedOccurrence subscribed
1006− propagate a $ switchSubscribedSubscribers subscribed
1007− SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do
1008− tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
1009− outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
1010− tracePropagate $ " outerHeight = " <> show outerHeight
1011− (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
1012− tracePropagate $ " isJust occ = " <> show (isJust occ)
1013− tracePropagate $ " innerHeight = " <> show innerHeight
1014− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $! Just innerSubd
1015− scheduleClear $ coincidenceSubscribedInnerParent subscribed
1016− case occ of
1017− Nothing -> do
1018− when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
1019− writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
1020− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
1021− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
1022− Just o -> do -- Since it's already firing, no need to adjust height
1023− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
1024− scheduleClear $ coincidenceSubscribedOccurrence subscribed
1025− propagate o $ coincidenceSubscribedSubscribers subscribed
1026− SubscriberCoincidenceInner subscribed -> {-# SCC "traverseCoincidenceInner" #-} do
1027− tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
1028− occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
1029− case occ of
1030− Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
1031− Nothing -> do
1032− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $! Just a
1033− scheduleClear $ coincidenceSubscribedOccurrence subscribed
1034− propagate a $ coincidenceSubscribedSubscribers subscribed
1035− SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
1036−
1037−{-# INLINE propagateSubscriberHold #-}
1038−propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()
1039−propagateSubscriberHold h a = do
1040− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
1041− invalidators <- liftIO $ readIORef $ holdInvalidators h
1042− return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1043− v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1044− case {-# SCC "apply" #-} R.apply a v of
1045− Nothing -> return ()
1046− Just v' -> do
1047− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1048− vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1049− iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1050− defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1051−
1052−data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1053−
1054−{-# INLINE subscribeCoincidenceInner #-}
1055−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
1056−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
1057− subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1058− subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
1059− innerOcc <- liftIO $ readEventSubscribed innerSubd
1060− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
1061− let height = max innerHeight outerHeight
1062− defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
1063− return (innerOcc, height, innerSubd)
1064−
1065−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1066−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1067−readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1068−readBehaviorUntracked b = do
1069− holdInits <- getDeferralQueue
1070− liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1071−
1072−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a
1073−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1074−
1075−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
1076−askInvalidator = liftM (fmap fst . fst) $ BehaviorM ask
1077−
1078−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
1079−askParentsRef = liftM (fmap snd . fst) $ BehaviorM ask
1080−
1081−askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1082−askBehaviorHoldInits = liftM snd $ BehaviorM ask
1083−
1084−readBehaviorTracked :: Behavior a -> BehaviorM a
1085−readBehaviorTracked b = case b of
1086− BehaviorHold h -> readHoldTracked h
1087− BehaviorHoldIdentity h -> readHoldTracked h
1088− BehaviorConst a -> return a
1089− BehaviorPull p -> do
1090− val <- liftIO $ readIORef $ pullValue p
1091− case val of
1092− Just subscribed -> do
1093− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1094− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
1095− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
1096− return $ pullSubscribedValue subscribed
1097− Nothing -> do
1098− i <- liftIO $ newInvalidatorPull p
1099− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
1100− parentsRef <- liftIO $ newIORef []
1101− holdInits <- askBehaviorHoldInits
1102− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
1103− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
1104− parents <- liftIO $ readIORef parentsRef
1105− let subscribed = PullSubscribed
1106− { pullSubscribedValue = a
1107− , pullSubscribedInvalidators = invsRef
1108− , pullSubscribedOwnInvalidator = i
1109− , pullSubscribedParents = parents
1110− }
1111− liftIO $ writeIORef (pullValue p) $! Just subscribed
1112− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1113− return a
1114− BehaviorDyn d -> readHoldTracked =<< getDynHold d
1115− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1116−
1117−{-# INLINE readHoldTracked #-}
1118−readHoldTracked :: Hold p a -> BehaviorM a
1119−readHoldTracked h = do
1120− result <- liftIO $ readIORef $ holdValue h
1121− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1122− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1123− return result
1124−
1125−{-# INLINE getDynHold #-}
1126−getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)
1127−getDynHold d = do
1128− mh <- liftIO $ readIORef $ unDyn d
1129− case mh of
1130− Right h -> return h
1131− Left (readV0, v') -> do
1132− holdInits <- getDeferralQueue
1133− v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1134− h <- hold v0 v'
1135− liftIO $ writeIORef (unDyn d) $! Right h
1136− return h
1137−
1138−{-
1139−readEvent :: Event a -> ResultM (Maybe a)
1140−readEvent e = case e of
1141− EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
1142− EventNever -> return Nothing
1143− EventPush p -> do
1144− subscribed <- getPushSubscribed p
1145− liftIO $ readPushSubscribed subscribed
1146− EventMerge m -> do
1147− subscribed <- getMergeSubscribed m
1148− liftIO $ readMergeSubscribed subscribed
1149− EventFan k f -> do
1150− subscribed <- getFanSubscribed f
1151− liftIO $ readFanSubscribed k subscribed
1152− EventSwitch s -> do
1153− subscribed <- getSwitchSubscribed s
1154− liftIO $ readSwitchSubscribed subscribed
1155− EventCoincidence c -> do
1156− subscribed <- getCoincidenceSubscribed c
1157− liftIO $ readCoincidenceSubscribed subscribed
1158− EventHold h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1159− EventDyn d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1160− EventHoldIdentity h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1161− EventDynIdentity d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1162−-}
1163−
1164−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1165−readEventSubscribed = \case
1166− EventSubscribedRoot rs -> readRootSubscribed rs
1167− EventSubscribedNever -> return Nothing
1168− EventSubscribedPush ps -> readPushSubscribed ps
1169− EventSubscribedMerge ms -> readMergeSubscribed ms
1170− EventSubscribedFan k fs -> readFanSubscribed k fs
1171− EventSubscribedSwitch ss -> readSwitchSubscribed ss
1172− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1173−
1174−readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1175−readRootSubscribed = rootSubscribedOccurrence
1176−
1177−readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)
1178−readPushSubscribed subscribed = do
1179− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1180− touch $ pushSubscribedSelf subscribed
1181− return result
1182−
1183−readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1184−readMergeSubscribed subscribed = do
1185− result <- readIORef $ mergeSubscribedOccurrence subscribed
1186− touch $ mergeSubscribedParents subscribed
1187− return result
1188−
1189−readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
1190−readFanSubscribed k fs = do
1191− parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs
1192− return $ coerce $ DMap.lookup k =<< parentOcc
1193−
1194−readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1195−readSwitchSubscribed subscribed = do
1196− result <- readIORef $ switchSubscribedOccurrence subscribed
1197− touch $ switchSubscribedOwnInvalidator subscribed
1198− return result
1199−
1200−readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)
1201−readCoincidenceSubscribed subscribed = do
1202− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1203− touch $ coincidenceSubscribedOuter subscribed
1204− --TODO: do we need to touch the inner subscriber?
1205− return result
1206−
1207−-- Always refers to 0
1208−{-# NOINLINE zeroRef #-}
1209−zeroRef :: IORef Height
1210−zeroRef = unsafePerformIO $ newIORef zeroHeight
1211−
1212−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1213−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1214−subscribe e sub = case e of
1215− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1216− EventNever -> return $ EventSubscription Nothing EventSubscribedNever
1217− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
1218− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
1219− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
1220− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
1221− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
1222− EventHold h -> subscribeHoldEvent h sub
1223− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1224− EventHoldIdentity h -> subscribeHoldEvent h sub
1225− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1226− where
1227− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1228− wrap tag getSpecificSubscribed = do
1229− (sln, subd) <- getSpecificSubscribed sub
1230− return $ EventSubscription (Just sln) $ tag subd
1231−
1232−{-# INLINE subscribeHoldEvent #-}
1233−subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1234−subscribeHoldEvent h sub = do
1235− EventSubscription _ subd <- getHoldEventSubscription h
1236− sln <- liftIO $ subscribeEventSubscribed subd sub
1237− return $ EventSubscription sln subd
1238−
1239−{-# INLINE debugSubscribe #-}
1240−debugSubscribe :: Bool
1241−debugSubscribe = False
1242−
1243−{-# INLINE subscribeEventSubscribed #-}
1244−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
1245−subscribeEventSubscribed es sub = case es of
1246− EventSubscribedRoot r -> do
1247− traceSubscribe $ "subscribeEventSubscribed Root"
1248− fmap Just $ subscribeRootSubscribed r sub
1249− EventSubscribedNever -> do
1250− traceSubscribe $ "subscribeEventSubscribed Never"
1251− return Nothing
1252− EventSubscribedPush subscribed -> do
1253− traceSubscribe $ "subscribeEventSubscribed Push"
1254− fmap Just $ subscribePushSubscribed subscribed sub
1255− EventSubscribedFan k subscribed -> do
1256− traceSubscribe $ "subscribeEventSubscribed Fan"
1257− fmap Just $ subscribeFanSubscribed k subscribed sub
1258− EventSubscribedMerge subscribed -> do
1259− traceSubscribe $ "subscribeEventSubscribed Merge"
1260− fmap Just $ subscribeMergeSubscribed subscribed sub
1261− EventSubscribedSwitch subscribed -> do
1262− traceSubscribe $ "subscribeEventSubscribed Switch"
1263− fmap Just $ subscribeSwitchSubscribed subscribed sub
1264− EventSubscribedCoincidence subscribed -> do
1265− traceSubscribe $ "subscribeEventSubscribed Coincidence"
1266− fmap Just $ subscribeCoincidenceSubscribed subscribed sub
1267−
1268−{-# INLINE eventSubscribedHeightRef #-}
1269−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
1270−eventSubscribedHeightRef = \case
1271− EventSubscribedRoot _ -> zeroRef
1272− EventSubscribedNever -> zeroRef
1273− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1274− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
1275− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
1276− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
1277− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
1278−
1279−{-# INLINE eventSubscribedHasOwnHeightRef #-}
1280−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1281−eventSubscribedHasOwnHeightRef = \case
1282− EventSubscribedRoot _ -> False
1283− EventSubscribedNever -> False
1284− EventSubscribedPush _ -> False
1285− EventSubscribedFan _ _ -> False
1286− EventSubscribedMerge _ -> True
1287− EventSubscribedSwitch _ -> True
1288− EventSubscribedCoincidence _ -> True
1289−
1290−{-# INLINE eventSubscribedGetParents #-}
1291−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1292−eventSubscribedGetParents = \case
1293− EventSubscribedRoot _ -> return []
1294− EventSubscribedNever -> return []
1295− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
1296− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
1297− EventSubscribedMerge subscribed -> do
1298− ps <- readIORef $ mergeSubscribedParents subscribed
1299− return $ fmap (\(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v) $ DMap.toList ps
1300− EventSubscribedSwitch subscribed -> do
1301− s <- readIORef $ switchSubscribedCurrentParent subscribed
1302− return [Some.This $ _eventSubscription_subscribed s]
1303− EventSubscribedCoincidence subscribed -> do
1304− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1305− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1306− innerParents = maybeToList $ fmap Some.This innerSubscription
1307− return $ outerParent : innerParents
1308−
1309−type CanSubscribe x m =
1310− ( HasSpiderEnv x m
1311− , HasCurrentHeight m
1312− , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1313− , Defer SomeClear m -- Wiping out event firings
1314− , Defer SomeAssignment m -- Updating state
1315− , Defer SomeResetCoincidence m
1316− )
1317−
1318−getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
1319−getRootSubscribed k r sub = do
1320− mSubscribed <- readIORef $ rootSubscribed r
1321− case DMap.lookup k mSubscribed of
1322− Just subscribed -> {-# SCC "hitRoot" #-} do
1323− sln <- subscribeRootSubscribed subscribed sub
1324− return (sln, subscribed)
1325− Nothing -> {-# SCC "missRoot" #-} do
1326− weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1327− let !cached = rootSubscribed r
1328− uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1329− (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1330− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1331− uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1332− writeIORef uninitRef $! uninit
1333− let subscribed = RootSubscribed
1334− { rootSubscribedKey = k
1335− , rootSubscribedCachedSubscribed = cached
1336− , rootSubscribedOccurrence = liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1337− , rootSubscribedSubscribers = subs
1338− , rootSubscribedUninit = uninit
1339− , rootSubscribedWeakSelf = weakSelf
1340−#ifdef DEBUG_NODEIDS
1341− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1342−#endif
1343− }
1344− writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1345− modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1346− return (sln, subscribed)
1347−
1348−cleanupRootSubscribed :: RootSubscribed a -> IO ()
1349−cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1350− rootSubscribedUninit self
1351− modifyIORef' cached $ DMap.delete k
1352−
1353−{-# INLINE subscribeRootSubscribed #-}
1354−subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1355−subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1356−
1357−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1358−{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}
1359−getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)
1360−getPushSubscribed p sub = do
1361− mSubscribed <- liftIO $ readIORef $ pushSubscribed p
1362− case mSubscribed of
1363− Just subscribed -> {-# SCC "hitPush" #-} do
1364− sln <- liftIO $ subscribePushSubscribed subscribed sub
1365− return (sln, subscribed)
1366− Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
1367− subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
1368− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1369− s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
1370− subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s
1371− parentOcc <- liftIO $ readEventSubscribed subd
1372− occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc
1373− occRef <- liftIO $ newIORef occ
1374− when (isJust occ) $ scheduleClear occRef
1375− weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"
1376− let !cached = pushSubscribed p
1377− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupPushSubscribed
1378− let subscribed = PushSubscribed
1379− { pushSubscribedCachedSubscribed = cached
1380− , pushSubscribedOccurrence = occRef
1381− , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
1382− , pushSubscribedSubscribers = subs
1383− , pushSubscribedSelf = s
1384− , pushSubscribedWeakSelf = weakSelf
1385− , pushSubscribedParent = subscription
1386−#ifdef DEBUG_NODEIDS
1387− , pushSubscribedNodeId = unsafeNodeId p
1388−#endif
1389− }
1390− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1391− liftIO $ writeIORef subscribedRef $! subscribed
1392− liftIO $ writeIORef (pushSubscribed p) $! Just subscribed
1393− return (sln, subscribed)
1394−
1395−cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1396−cleanupPushSubscribed self = do
1397− unsubscribe $ pushSubscribedParent self
1398− writeIORef (pushSubscribedCachedSubscribed self) $! Nothing
1399−
1400−{-# INLINE subscribePushSubscribed #-}
1401−subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)
1402−subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
1403−
1404−{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}
1405−getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)
1406−getMergeSubscribed m sub = do
1407− mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
1408− case mSubscribed of
1409− Just subscribed -> {-# SCC "hitMerge" #-} do
1410− sln <- liftIO $ subscribeMergeSubscribed subscribed sub
1411− return (sln, subscribed)
1412− Nothing -> {-# SCC "missMerge" #-} do
1413− subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1414− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1415− initialParents <- readBehaviorUntracked $ current $ mergeParents m
1416− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1417− s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1418− subscription@(EventSubscription _ parentSubd) <- subscribe e s
1419− parentOcc <- liftIO $ readEventSubscribed parentSubd
1420− height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1421− return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))
1422− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers
1423− heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1424− myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1425− myHeight = if any (== invalidHeight) heights
1426− then invalidHeight
1427− else succHeight $ heightBagMax myHeightBag
1428− currentHeight <- getCurrentHeight
1429− let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1430− then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1431− else (Nothing, dm)
1432− when (not $ DMap.null accum) $ do
1433− scheduleMerge myHeight subscribedUnsafe
1434− occRef <- liftIO $ newIORef occ
1435− when (isJust occ) $ scheduleClear occRef
1436− accumRef <- liftIO $ newIORef accum
1437− heightRef <- liftIO $ newIORef myHeight
1438− heightMapRef <- liftIO $ newIORef myHeightBag
1439− weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
1440− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
1441− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1442− parentsRef <- liftIO $ newIORef $ DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1443− let !subscribed = MergeSubscribed
1444− { mergeSubscribedCachedSubscribed = mergeSubscribed m
1445− , mergeSubscribedOccurrence = occRef
1446− , mergeSubscribedAccum = accumRef
1447− , mergeSubscribedHeight = heightRef
1448− , mergeSubscribedHeightBag = heightMapRef
1449− , mergeSubscribedSubscribers = subs
1450− , mergeSubscribedChange = changeSubdRef
1451− , mergeSubscribedParents = parentsRef
1452− , mergeSubscribedWeakSelf = weakSelf
1453−#ifdef DEBUG_NODEIDS
1454− , mergeSubscribedNodeId = unsafeNodeId m
1455−#endif
1456− }
1457− defer $ SomeMergeInit subscribed $ updated $ mergeParents m
1458− liftIO $ writeIORef subscribedRef $! subscribed
1459− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1460− liftIO $ writeIORef (mergeSubscribed m) $! Just subscribed
1461− return (sln, subscribed)
1462−
1463−cleanupMergeSubscribed :: MergeSubscribed k -> IO ()
1464−cleanupMergeSubscribed subscribed = do
1465− parents <- readIORef $ mergeSubscribedParents subscribed
1466− forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp
1467− -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty
1468− writeIORef (mergeSubscribedCachedSubscribed subscribed) $! Nothing -- Get rid of the cached subscribed
1469−
1470−{-# INLINE subscribeMergeSubscribed #-}
1471−subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))
1472−subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
1473−
1474−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}
1475−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)
1476−getFanSubscribed k f sub = do
1477− mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1478− case mSubscribed of
1479− Just subscribed -> {-# SCC "hitFan" #-} do
1480− sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1481− return (sln, subscribed)
1482− Nothing -> {-# SCC "missFan" #-} do
1483− subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1484− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1485− s <- liftIO $ newSubscriberFan subscribedUnsafe
1486− subscription <- subscribe (fanParent f) s
1487− weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1488− (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1489− subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1490− let subscribed = FanSubscribed
1491− { fanSubscribedCachedSubscribed = fanSubscribed f
1492− , fanSubscribedParent = subscription
1493− , fanSubscribedSubscribers = subscribersRef
1494−#ifdef DEBUG_NODEIDS
1495− , fanSubscribedNodeId = unsafeNodeId f
1496−#endif
1497− }
1498− let !self = (k, subscribed)
1499− liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1500− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1501− liftIO $ writeIORef subscribedRef $! subscribed
1502− liftIO $ writeIORef (fanSubscribed f) $! Just subscribed
1503− return (slnForSub, subscribed)
1504−
1505−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1506−cleanupFanSubscribed (k, subscribed) = do
1507− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1508− let reducedSubscribers = DMap.delete k subscribers
1509− if DMap.null reducedSubscribers
1510− then do
1511− unsubscribe $ fanSubscribedParent subscribed
1512− -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1513− writeIORef (fanSubscribedCachedSubscribed subscribed) $! Nothing
1514− else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1515−
1516−{-# INLINE subscribeFanSubscribed #-}
1517−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)
1518−subscribeFanSubscribed k subscribed sub = do
1519− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1520− case DMap.lookup k subscribers of
1521− Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1522− let !self = (k, subscribed)
1523− weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1524− (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1525− writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeEventSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers
1526− return sln
1527− Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1528−
1529−{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1530−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)
1531−getSwitchSubscribed s sub = do
1532− mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1533− case mSubscribed of
1534− Just subscribed -> {-# SCC "hitSwitch" #-} do
1535− sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1536− return (sln, subscribed)
1537− Nothing -> {-# SCC "missSwitch" #-} do
1538− subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1539− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1540− i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1541− mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1542− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1543− wiRef <- liftIO $ newIORef wi
1544− parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1545− holdInits <- getDeferralQueue
1546− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1547− subscription@(EventSubscription _ subd) <- subscribe e mySub
1548− subscriptionRef <- liftIO $ newIORef subscription
1549− parentOcc <- liftIO $ readEventSubscribed subd
1550− occRef <- liftIO $ newIORef parentOcc
1551− when (isJust parentOcc) $ scheduleClear occRef
1552− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
1553− weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1554− (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1555− let !subscribed = SwitchSubscribed
1556− { switchSubscribedCachedSubscribed = switchSubscribed s
1557− , switchSubscribedOccurrence = occRef
1558− , switchSubscribedHeight = heightRef
1559− , switchSubscribedSubscribers = subs
1560− , switchSubscribedOwnInvalidator = i
1561− , switchSubscribedOwnWeakInvalidator = wiRef
1562− , switchSubscribedBehaviorParents = parentsRef
1563− , switchSubscribedParent = switchParent s
1564− , switchSubscribedCurrentParent = subscriptionRef
1565− , switchSubscribedWeakSelf = weakSelf
1566−#ifdef DEBUG_NODEIDS
1567− , switchSubscribedNodeId = unsafeNodeId s
1568−#endif
1569− }
1570− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1571− liftIO $ writeIORef subscribedRef $! subscribed
1572− liftIO $ writeIORef (switchSubscribed s) $! Just subscribed
1573− return (slnForSub, subscribed)
1574−
1575−cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1576−cleanupSwitchSubscribed subscribed = do
1577− unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1578− finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1579− writeIORef (switchSubscribedCachedSubscribed subscribed) $! Nothing
1580−
1581−{-# INLINE subscribeSwitchSubscribed #-}
1582−subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1583−subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1584−
1585−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1586−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)
1587−getCoincidenceSubscribed c sub = do
1588− mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1589− case mSubscribed of
1590− Just subscribed -> {-# SCC "hitCoincidence" #-} do
1591− sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1592− return (sln, subscribed)
1593− Nothing -> {-# SCC "missCoincidence" #-} do
1594− subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1595− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1596− subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1597− outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
1598− outerOcc <- liftIO $ readEventSubscribed outerSubd
1599− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1600− (occ, height, mInnerSubd) <- case outerOcc of
1601− Nothing -> return (Nothing, outerHeight, Nothing)
1602− Just o -> do
1603− (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1604− return (occ, height, Just innerSubd)
1605− occRef <- liftIO $ newIORef occ
1606− when (isJust occ) $ scheduleClear occRef
1607− heightRef <- liftIO $ newIORef height
1608− innerSubdRef <- liftIO $ newIORef mInnerSubd
1609− scheduleClear innerSubdRef
1610− weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1611− (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1612− let subscribed = CoincidenceSubscribed
1613− { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1614− , coincidenceSubscribedOccurrence = occRef
1615− , coincidenceSubscribedHeight = heightRef
1616− , coincidenceSubscribedSubscribers = subs
1617− , coincidenceSubscribedOuter = subOuter
1618− , coincidenceSubscribedOuterParent = outerSubscription
1619− , coincidenceSubscribedInnerParent = innerSubdRef
1620− , coincidenceSubscribedWeakSelf = weakSelf
1621−#ifdef DEBUG_NODEIDS
1622− , coincidenceSubscribedNodeId = unsafeNodeId c
1623−#endif
1624− }
1625− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1626− liftIO $ writeIORef subscribedRef $! subscribed
1627− liftIO $ writeIORef (coincidenceSubscribed c) $! Just subscribed
1628− return (slnForSub, subscribed)
1629−
1630−cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1631−cleanupCoincidenceSubscribed subscribed = do
1632− unsubscribe $ coincidenceSubscribedOuterParent subscribed
1633− writeIORef (coincidenceSubscribedCachedSubscribed subscribed) $! Nothing
1634−
1635−{-# INLINE subscribeCoincidenceSubscribed #-}
1636−subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1637−subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1638−
1639−{-# INLINE merge #-}
1640−merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
1641−merge m = EventMerge $ Merge
1642− { mergeParents = m
1643− , mergeSubscribed = unsafeNewIORef m Nothing
1644− }
1645−
1646−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1647−
1648−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1649−fan e =
1650− let f = Fan
1651− { fanParent = e
1652− , fanSubscribed = unsafeNewIORef e Nothing
1653− }
1654− in EventSelector $ \k -> EventFan k f
1655−
1656−{- SPECIALIZE runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x () #-}
1657−--runHoldInits :: (CanSubscribe x m, Defer SomeMergeUpdate m) => IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> m ()
1658−runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1659−runHoldInits holdInitRef mergeInitRef = do
1660− holdInits <- liftIO $ readIORef holdInitRef
1661− mergeInits <- liftIO $ readIORef mergeInitRef
1662− if null holdInits && null mergeInits then return () else do
1663− liftIO $ writeIORef holdInitRef $! []
1664− liftIO $ writeIORef mergeInitRef $! []
1665− mapM_ initHold holdInits
1666− mapM_ initMerge mergeInits
1667− runHoldInits holdInitRef mergeInitRef
1668−
1669−{- SPECIALIZE initHold :: SomeHoldInit -> EventM x () #-}
1670−--initHold :: CanSubscribe x m => SomeHoldInit -> m ()
1671−initHold :: SomeHoldInit -> EventM x ()
1672−initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1673−
1674−{- SPECIALIZE initMerge :: SomeMergeInit -> EventM x () #-}
1675−--initMerge :: (CanSubscribe x m, Defer SomeMergeUpdate m) => SomeMergeInit -> m ()
1676−initMerge :: SomeMergeInit -> EventM x ()
1677−initMerge (SomeMergeInit subscribed changed) = do
1678− changeSub <- liftIO $ newSubscriberMergeChange subscribed
1679− EventSubscription _ changeSubd <- subscribe changed changeSub
1680− change <- liftIO $ readEventSubscribed changeSubd
1681− forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1682− liftIO $ writeIORef (mergeSubscribedChange subscribed) $! (changeSub, changeSubd)
1683−
1684−-- | Run an event action outside of a frame
1685−runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1686−runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1687− -- 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
1688− pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)
1689− {-# SCC "cleanups" #-} sequence_ pendingCleanups
1690− toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1691− holdInitRef <- newIORef []
1692− mergeUpdateRef <- newIORef []
1693− mergeInitRef <- newIORef []
1694− heightRef <- newIORef zeroHeight
1695− toClearRef <- newIORef []
1696− toClearRootRef <- newIORef []
1697− coincidenceInfosRef <- newIORef []
1698− delayedRef <- liftIO $ newIORef IntMap.empty
1699− let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1700− let go = do
1701− result <- a
1702− 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
1703− return result
1704− result <- runEventM go env
1705− toClear <- readIORef toClearRef
1706− forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref $! Nothing
1707− toClearRoot <- readIORef toClearRootRef
1708− forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1709− toAssign <- readIORef toAssignRef
1710− toReconnectRef <- newIORef []
1711− coincidenceInfos <- readIORef coincidenceInfosRef
1712− forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1713− writeIORef vRef v
1714− when debugInvalidate $ putStrLn $ "Invalidating Hold"
1715− writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1716− mergeUpdates <- readIORef mergeUpdateRef
1717− writeIORef mergeUpdateRef $! []
1718− let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1719− updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do
1720− oldParents <- readIORef $ mergeSubscribedParents m
1721− let f (subscriptionsToKill, ps) (k :=> Compose me) = do
1722− (mOldSubd, newPs) <- case me of
1723− Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1724− Just e -> do
1725− s <- liftIO $ newSubscriberMerge k m
1726− subscription@(EventSubscription _ subd) <- subscribe e s
1727− let newParent = MergeSubscribedParent subscription s
1728− newParentHeight <- liftIO $ getEventSubscribedHeight subd
1729− liftIO $ addMergeHeight newParentHeight m
1730− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1731− forM_ mOldSubd $ \oldSubd -> do
1732− oldHeight <- liftIO $ readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1733− liftIO $ removeMergeHeight oldHeight m
1734− return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1735− (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
1736− writeIORef (mergeSubscribedParents m) $! newParents
1737− return subscriptionsToKill
1738− when debugPropagate $ putStrLn "Updating merges"
1739− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1740− when debugPropagate $ putStrLn "Updating merges done"
1741− toReconnect <- readIORef toReconnectRef
1742− switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1743− oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1744− wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1745− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
1746− finalize wi
1747− i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1748− wi' <- mkWeakPtrWithDebug i "wi'"
1749− writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
1750− writeIORef (switchSubscribedBehaviorParents subscribed) $! []
1751− writeIORef holdInitRef $! [] --TODO: Should we reuse this?
1752− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1753− 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
1754− --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1755− sub <- newSubscriberSwitch subscribed
1756− subscription <- 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
1757− {-
1758− stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1759− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1760− EventRoot _ -> "EventRoot"
1761− EventNever -> "EventNever"
1762− _ -> "something else"
1763− -}
1764− writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1765− return $ SomeEventSubscription oldSubscription
1766− forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1767− forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1768− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1769− EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1770− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1771− myHeight <- readIORef $ switchSubscribedHeight subscribed
1772− when (parentHeight /= myHeight) $ do
1773− writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1774− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1775− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> do
1776− invalidateMergeHeight m --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
1777− forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1778− unsubscribe subscription
1779− mapM_ invalidateCoincidenceHeight mcs
1780− forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1781− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1782− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1783− height <- calculateSwitchHeight subscribed
1784− updateSwitchHeight height subscribed
1785− return result
1786−
1787−newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1788−
1789−{-# INLINE zeroHeight #-}
1790−zeroHeight :: Height
1791−zeroHeight = Height 0
1792−
1793−{-# INLINE invalidHeight #-}
1794−invalidHeight :: Height
1795−invalidHeight = Height (-1000)
1796−
1797−-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1798−{-# INLINE invalidHeightBeingTraversed #-}
1799−invalidHeightBeingTraversed :: Height
1800−invalidHeightBeingTraversed = Height (-1001)
1801−
1802−{-# INLINE succHeight #-}
1803−succHeight :: Height -> Height
1804−succHeight h@(Height a) =
1805− if h == invalidHeight
1806− then invalidHeight
1807− else Height $ succ a
1808−
1809−invalidateSubscriberHeight :: Height -> Subscriber a -> IO ()
1810−invalidateSubscriberHeight old s = case s of
1811− SubscriberPush _ subscribed -> do
1812− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1813− WeakBag.traverse (pushSubscribedSubscribers subscribed) $ invalidateSubscriberHeight old
1814− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1815− SubscriberMerge _ subscribed -> do
1816− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1817− removeMergeHeight old subscribed
1818− invalidateMergeHeight subscribed
1819− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1820− SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
1821− SubscriberFan subscribed -> do
1822− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1823− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1824− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
1825− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1826− SubscriberHold _ -> return ()
1827− SubscriberHoldIdentity _ -> return ()
1828− SubscriberSwitch subscribed -> do
1829− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1830− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1831− when (oldHeight /= invalidHeight) $ do
1832− writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1833− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1834− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1835− SubscriberCoincidenceOuter subscribed -> do
1836− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1837− invalidateCoincidenceHeight subscribed
1838− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1839− SubscriberCoincidenceInner subscribed -> do
1840− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1841− invalidateCoincidenceHeight subscribed
1842− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1843− SubscriberHandle -> return ()
1844−
1845−removeMergeHeight :: Height -> MergeSubscribed k -> IO ()
1846−removeMergeHeight oldParentHeight subscribed = do
1847− when debugInvalidateHeight $ putStrLn $ "removeMergeHeight: " <> show oldParentHeight <> " Merge" <> showNodeId subscribed
1848− oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1849− let newHeights = heightBagRemove oldParentHeight oldHeights
1850− writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1851−
1852−invalidateMergeHeight :: MergeSubscribed k -> IO ()
1853−invalidateMergeHeight subscribed = do
1854− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1855− -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1856− when (oldHeight /= invalidHeight) $ do
1857− writeIORef (mergeSubscribedHeight subscribed) $! invalidHeight
1858− WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1859−
1860−addMergeHeight :: Height -> MergeSubscribed k -> IO ()
1861−addMergeHeight newParentHeight subscribed = do
1862− when debugInvalidateHeight $ putStrLn $ "addMergeHeight: " <> show newParentHeight <> " Merge" <> showNodeId subscribed
1863− oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1864− let newHeights = heightBagAdd newParentHeight oldHeights
1865− writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1866−
1867−revalidateMergeHeight :: MergeSubscribed k -> IO ()
1868−revalidateMergeHeight subscribed = do
1869− currentHeight <- readIORef $ mergeSubscribedHeight subscribed
1870− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1871− heights <- readIORef $ mergeSubscribedHeightBag subscribed
1872− parents <- readIORef $ mergeSubscribedParents subscribed
1873− -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1874− case heightBagSize heights `compare` DMap.size parents of
1875− LT -> return ()
1876− EQ -> do
1877− let height = succHeight $ heightBagMax heights
1878− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1879− writeIORef (mergeSubscribedHeight subscribed) $! height
1880− WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1881− GT -> error $ "revalidateMergeHeight: more heights than parents for Merge" <> showNodeId subscribed
1882−
1883−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1884−invalidateCoincidenceHeight subscribed = do
1885− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1886− when (oldHeight /= invalidHeight) $ do
1887− writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
1888− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1889−
1890−recalculateSubscriberHeight :: Height -> Subscriber a -> IO ()
1891−recalculateSubscriberHeight new s = case s of
1892− SubscriberPush _ subscribed -> do
1893− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1894− WeakBag.traverse (pushSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1895− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1896− SubscriberMerge _ subscribed -> do
1897− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1898− addMergeHeight new subscribed
1899− revalidateMergeHeight subscribed
1900− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1901− SubscriberMergeChange _ -> return ()
1902− SubscriberFan subscribed -> do
1903− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1904− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1905− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
1906− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1907− SubscriberHold _ -> return ()
1908− SubscriberHoldIdentity _ -> return ()
1909− SubscriberSwitch subscribed -> do
1910− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1911− updateSwitchHeight new subscribed
1912− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1913− SubscriberCoincidenceOuter subscribed -> do
1914− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1915− recalculateCoincidenceHeight subscribed
1916− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1917− SubscriberCoincidenceInner subscribed -> do
1918− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1919− recalculateCoincidenceHeight subscribed
1920− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1921− SubscriberHandle -> return ()
1922−
1923−updateSwitchHeight :: Height -> SwitchSubscribed a -> IO ()
1924−updateSwitchHeight new subscribed = do
1925− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1926− when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1927− when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1928− writeIORef (switchSubscribedHeight subscribed) $! new
1929− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1930−
1931−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1932−recalculateCoincidenceHeight subscribed = do
1933− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1934− when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1935− height <- calculateCoincidenceHeight subscribed
1936− when (height /= invalidHeight) $ do
1937− writeIORef (coincidenceSubscribedHeight subscribed) $! height
1938− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1939−
1940−getEventSubscribedHeight :: EventSubscribed a -> IO Height
1941−getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
1942−
1943−calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1944−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1945−
1946−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1947−calculateCoincidenceHeight subscribed = do
1948− outerHeight <- readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1949− innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1950− return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1951−
1952−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1953−
1954−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1955−invalidate toReconnectRef wis = do
1956− forM_ wis $ \wi -> do
1957− mi <- deRefWeak wi
1958− case mi of
1959− Nothing -> do
1960− traceInvalidate "invalidate Dead"
1961− return () --TODO: Should we clean this up here?
1962− Just i -> do
1963− finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1964− case i of
1965− InvalidatorPull p -> do
1966− traceInvalidate $ "invalidate: Pull" <> showNodeId p
1967− mVal <- readIORef $ pullValue p
1968− forM_ mVal $ \val -> do
1969− writeIORef (pullValue p) $! Nothing
1970− writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1971− InvalidatorSwitch subscribed -> do
1972− traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
1973− modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1974− 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
1975−
1976−--------------------------------------------------------------------------------
1977−-- Reflex integration
1978−--------------------------------------------------------------------------------
1979−
1980−type Spider = SpiderEnv Global
1981−
1982−data Global
1983−
1984−{-# NOINLINE globalSpiderEnv #-}
1985−globalSpiderEnv :: SpiderEnv Global
1986−globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv
1987−
1988−type role SpiderEnv nominal
1989−data SpiderEnv x = SpiderEnv
1990− { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])
1991− , _spiderEnv_lock :: !(MVar ())
1992− , _spiderEnv_cleanups :: !(IORef [IO ()])
1993−#ifdef DEBUG
1994− , _spiderEnv_depth :: !(IORef Int)
1995−#endif
1996− }
1997−
1998−instance GEq SpiderEnv where
1999− a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
2000− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments
2001− else Nothing
2002−
2003−unsafeNewSpiderEnv :: forall x. IO (SpiderEnv x)
2004−unsafeNewSpiderEnv = do
2005− toUnsubscribe <- newIORef []
2006− lock <- newMVar ()
2007− cleanups <- newIORef []
2008−#ifdef DEBUG
2009− depthRef <- newIORef 0
2010−#endif
2011− return $ SpiderEnv
2012− { _spiderEnv_toUnsubscribe = toUnsubscribe
2013− , _spiderEnv_lock = lock
2014− , _spiderEnv_cleanups = cleanups
2015−#ifdef DEBUG
2016− , _spiderEnv_depth = depthRef
2017−#endif
2018− }
2019−
2020−newSpiderEnv :: IO (Some SpiderEnv)
2021−newSpiderEnv = Some.This <$> unsafeNewSpiderEnv
2022−
2023−newtype SpiderPullM x a = SpiderPullM { runSpiderPullM :: BehaviorM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2024−
2025−newtype SpiderPushM x a = SpiderPushM { runSpiderPushM :: ComputeM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2026−
2027−instance R.Reflex (SpiderEnv x) where
2028− newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
2029− newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event a }
2030− newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
2031− newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
2032− type PullM (SpiderEnv x) = SpiderPullM x
2033− type PushM (SpiderEnv x) = SpiderPushM x
2034− {-# INLINABLE never #-}
2035− never = SpiderEvent EventNever
2036− {-# INLINABLE constant #-}
2037− constant = SpiderBehavior . BehaviorConst
2038− {-# INLINABLE push #-}
2039− push f = SpiderEvent . push (coerce f) . unSpiderEvent
2040− {-# INLINABLE pull #-}
2041− pull = SpiderBehavior . pull . coerce
2042− {-# INLINABLE merge #-}
2043− merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k Event)
2044− {-# INLINABLE fan #-}
2045− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2046− {-# INLINABLE switch #-}
2047− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderEnv x) a) -> Behavior (Event a)) . unSpiderBehavior
2048− {-# INLINABLE coincidence #-}
2049− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderEnv x) a) -> Event (Event a)) . unSpiderEvent
2050− {-# INLINABLE current #-}
2051− current = SpiderBehavior . current . unSpiderDynamic
2052− {-# INLINABLE updated #-}
2053− updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
2054− {-# INLINABLE unsafeBuildDynamic #-}
2055− unsafeBuildDynamic readV0 v' = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (coerce readV0) $ addIdentity $ unSpiderEvent v'
2056− {-# INLINABLE unsafeBuildIncremental #-}
2057− unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
2058− {-# INLINABLE mergeIncremental #-}
2059− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental
2060− {-# INLINABLE currentIncremental #-}
2061− currentIncremental = SpiderBehavior . current . unSpiderIncremental
2062− {-# INLINABLE updatedIncremental #-}
2063− updatedIncremental = SpiderEvent . updated . unSpiderIncremental
2064− {-# INLINABLE incrementalToDynamic #-}
2065− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
2066− c <- readBehaviorUntracked $ current i
2067− return $ fmap Identity $ R.apply p c --TODO: Avoid the redundant 'apply'
2068−
2069−instance R.MonadSample (SpiderEnv x) (EventM x) where
2070− {-# INLINABLE sample #-}
2071− sample (SpiderBehavior b) = readBehaviorUntracked b
2072−
2073−instance R.MonadHold (SpiderEnv x) (EventM x) where
2074− {-# INLINABLE hold #-}
2075− hold = holdSpiderEventM
2076− {-# INLINABLE holdDyn #-}
2077− holdDyn = holdDynSpiderEventM
2078− {-# INLINABLE holdIncremental #-}
2079− holdIncremental = holdIncrementalSpiderEventM
2080−
2081−holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)
2082−holdSpiderEventM v0 e = liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2083−
2084−holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)
2085−holdDynSpiderEventM v0 e = liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2086−
2087−holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)
2088−holdIncrementalSpiderEventM v0 e = liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2089−
2090−instance R.MonadHold (SpiderEnv x) (SpiderHost x) where
2091− {-# INLINABLE hold #-}
2092− hold v0 e = R.runHostFrame $ R.hold v0 e
2093− {-# INLINABLE holdDyn #-}
2094− holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
2095− {-# INLINABLE holdIncremental #-}
2096− holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
2097−
2098−instance R.MonadSample (SpiderEnv x) (SpiderHost x) where
2099− {-# INLINABLE sample #-}
2100− sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2101−
2102−instance R.MonadSample (SpiderEnv x) (SpiderPullM x) where
2103− {-# INLINABLE sample #-}
2104− sample = coerce . readBehaviorTracked . unSpiderBehavior
2105−
2106−instance R.MonadSample (SpiderEnv x) (SpiderPushM x) where
2107− {-# INLINABLE sample #-}
2108− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2109−
2110−instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where
2111− {-# INLINABLE hold #-}
2112− hold v0 e = R.current <$> R.holdDyn v0 e
2113− {-# INLINABLE holdDyn #-}
2114− holdDyn v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e
2115− {-# INLINABLE holdIncremental #-}
2116− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderIncremental . DynamicHold) $ hold v0 e
2117−
2118−data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
2119−newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
2120−
2121−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where
2122− {-# INLINABLE subscribeEvent #-}
2123− subscribeEvent e = SpiderHostFrame $ do
2124− subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2125− return $ SpiderEventHandle subscription
2126−
2127−instance R.ReflexHost (SpiderEnv x) where
2128− type EventTrigger (SpiderEnv x) = RootTrigger
2129− type EventHandle (SpiderEnv x) = SpiderEventHandle
2130− type HostFrame (SpiderEnv x) = SpiderHostFrame x
2131−
2132−instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
2133− {-# INLINABLE readEvent #-}
2134− readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do
2135− let EventSubscription sln subscribed = unSpiderEventHandle h
2136− result <- readEventSubscribed subscribed
2137− touch sln
2138− return result
2139−
2140−instance MonadRef (EventM x) where
2141− type Ref (EventM x) = Ref IO
2142− {-# INLINABLE newRef #-}
2143− {-# INLINABLE readRef #-}
2144− {-# INLINABLE writeRef #-}
2145− newRef = liftIO . newRef
2146− readRef = liftIO . readRef
2147− writeRef r a = liftIO $ writeRef r a
2148−
2149−instance MonadAtomicRef (EventM x) where
2150− {-# INLINABLE atomicModifyRef #-}
2151− atomicModifyRef r f = liftIO $ atomicModifyRef r f
2152−
2153−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2154−
2155−instance Monad (SpiderHost x) where
2156− {-# INLINABLE (>>=) #-}
2157− SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2158− {-# INLINABLE (>>) #-}
2159− SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2160− {-# INLINABLE return #-}
2161− return x = SpiderHost $ return x
2162− {-# INLINABLE fail #-}
2163− fail s = SpiderHost $ fail s
2164−
2165−runSpiderHost :: SpiderHost Global a -> IO a
2166−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderEnv
2167−
2168−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2169−
2170−instance Monad (SpiderHostFrame x) where
2171− {-# INLINABLE (>>=) #-}
2172− SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2173− {-# INLINABLE (>>) #-}
2174− SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2175− {-# INLINABLE return #-}
2176− return x = SpiderHostFrame $ return x
2177− {-# INLINABLE fail #-}
2178− fail s = SpiderHostFrame $ fail s
2179−
2180−instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where
2181− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2182−
2183−addIdentity :: Event a -> Event (Identity a)
2184−--addIdentity = fmap Identity
2185−addIdentity = unsafeCoerce
2186−
2187−instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where
2188− {-# INLINABLE hold #-}
2189− hold v0 e = SpiderHostFrame $ liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2190− {-# INLINABLE holdDyn #-}
2191− holdDyn v0 e = SpiderHostFrame $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2192− {-# INLINABLE holdIncremental #-}
2193− holdIncremental v0 e = SpiderHostFrame $ liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2194−
2195−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
2196−newEventWithTriggerIO f = do
2197− es <- newFanEventWithTriggerIO $ \Refl -> f
2198− return $ select es Refl
2199−
2200−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
2201−newFanEventWithTriggerIO f = do
2202− occRef <- newIORef DMap.empty
2203− subscribedRef <- newIORef DMap.empty
2204− let !r = Root
2205− { rootOccurrence = occRef
2206− , rootSubscribed = subscribedRef
2207− , rootInit = f
2208− }
2209− return $ EventSelector $ \k -> EventRoot k r
2210−
2211−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where
2212− newEventWithTrigger = SpiderHost . lift . liftM SpiderEvent . newEventWithTriggerIO
2213− newFanEventWithTrigger f = SpiderHost $ lift $ do
2214− es <- newFanEventWithTriggerIO f
2215− return $ R.EventSelector $ SpiderEvent . select es
2216−
2217−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where
2218− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
2219− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2220− es <- newFanEventWithTriggerIO f
2221− return $ R.EventSelector $ SpiderEvent . select es
2222−
2223−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where
2224− {-# INLINABLE subscribeEvent #-}
2225− subscribeEvent = subscribeEventSpiderHost
2226−
2227−subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)
2228−subscribeEventSpiderHost e = do
2229− subscription <- runFrame $ subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2230− return $ SpiderEventHandle subscription
2231−
2232−newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)
2233−
2234−instance R.MonadSample (SpiderEnv x) (ReadPhase x) where
2235− {-# INLINABLE sample #-}
2236− sample = ReadPhase . R.sample
2237−
2238−instance R.MonadHold (SpiderEnv x) (ReadPhase x) where
2239− {-# INLINABLE hold #-}
2240− hold v0 e = ReadPhase $ R.hold v0 e
2241− {-# INLINABLE holdDyn #-}
2242− holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2243− {-# INLINABLE holdIncremental #-}
2244− holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
2245−
2246−instance R.MonadReflexHost (SpiderEnv x) (SpiderHost x) where
2247− type ReadPhase (SpiderHost x) = ReadPhase x
2248− fireEventsAndRead es (ReadPhase a) = run es a
2249− runHostFrame = runFrame . runSpiderHostFrame
2250−
2251−instance MonadRef (SpiderHost x) where
2252− type Ref (SpiderHost x) = Ref IO
2253− newRef = SpiderHost . newRef
2254− readRef = SpiderHost . readRef
2255− writeRef r = SpiderHost . writeRef r
2256−
2257−instance MonadAtomicRef (SpiderHost x) where
2258− atomicModifyRef r = SpiderHost . atomicModifyRef r
2259−
2260−instance MonadRef (SpiderHostFrame x) where
2261− type Ref (SpiderHostFrame x) = Ref IO
2262− newRef = SpiderHostFrame . newRef
2263− readRef = SpiderHostFrame . readRef
2264− writeRef r = SpiderHostFrame . writeRef r
2265−
2266−instance MonadAtomicRef (SpiderHostFrame x) where
2267− atomicModifyRef r = SpiderHostFrame . atomicModifyRef r