@@ -1,1443 +0,0 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
2−module Reflex.Spider.Internal where
3−
4−import qualified Reflex.Class as R
5−import qualified Reflex.Host.Class as R
6−
7−import Data.IORef
8−import System.Mem.Weak
9−import Data.Foldable
10−import Data.Traversable
11−import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
12−import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
13−import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
14−import GHC.Exts
15−import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
16−import Data.Dependent.Map (DMap, DSum (..))
17−import qualified Data.Dependent.Map as DMap
18−import Data.GADT.Compare
19−import Data.Maybe
20−import Data.IntMap (IntMap)
21−import qualified Data.IntMap as IntMap
22−import Control.Monad.Ref
23−import Control.Monad.Exception
24−import Data.Monoid ((<>))
25−import Data.Coerce
26−
27−import System.IO.Unsafe
28−import Unsafe.Coerce
29−import Control.Monad.Primitive
30−
31−-- Note: must come last to silence warnings due to AMP on GHC < 7.10
32−import Prelude hiding (mapM, mapM_, any, sequence, concat)
33−
34−debugPropagate :: Bool
35−
36−debugInvalidateHeight :: Bool
37−
38−#ifdef DEBUG
39−
40−#define DEBUG_NODEIDS
41−
42−debugPropagate = True
43−
44−debugInvalidateHeight = True
45−
46−class HasNodeId a where
47− getNodeId :: a -> Int
48−
49−instance HasNodeId (Hold a) where
50− getNodeId = holdNodeId
51−
52−instance HasNodeId (PushSubscribed a b) where
53− getNodeId = pushSubscribedNodeId
54−
55−instance HasNodeId (SwitchSubscribed a) where
56− getNodeId = switchSubscribedNodeId
57−
58−instance HasNodeId (MergeSubscribed a) where
59− getNodeId = mergeSubscribedNodeId
60−
61−instance HasNodeId (FanSubscribed a) where
62− getNodeId = fanSubscribedNodeId
63−
64−instance HasNodeId (CoincidenceSubscribed a) where
65− getNodeId = coincidenceSubscribedNodeId
66−
67−instance HasNodeId (RootSubscribed a) where
68− getNodeId = rootSubscribedNodeId
69−
70−showNodeId :: HasNodeId a => a -> String
71−showNodeId = ("#"<>) . show . getNodeId
72−
73−#else
74−
75−debugPropagate = False
76−
77−debugInvalidateHeight = False
78−
79−showNodeId :: a -> String
80−showNodeId = const ""
81−
82−#endif
83−
84−#ifdef DEBUG_NODEIDS
85−{-# NOINLINE nextNodeIdRef #-}
86−nextNodeIdRef :: IORef Int
87−nextNodeIdRef = unsafePerformIO $ newIORef 1
88−
89−{-# NOINLINE unsafeNodeId #-}
90−unsafeNodeId :: a -> Int
91−unsafeNodeId a = unsafePerformIO $ do
92− touch a
93− atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
94−#endif
95−
96−--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
97−--type role Hold representational
98−data Hold a
99− = Hold { holdValue :: !(IORef a)
100− , holdInvalidators :: !(IORef [Weak Invalidator])
101− -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'
102− , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef
103− , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef
104−#ifdef DEBUG_NODEIDS
105− , holdNodeId :: Int
106−#endif
107− }
108−
109−data EventEnv
110− = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
111− , eventEnvHoldInits :: !(IORef [SomeHoldInit])
112− , eventEnvClears :: !(IORef [SomeMaybeIORef])
113− , eventEnvRootClears :: !(IORef [SomeDMapIORef])
114− , eventEnvCurrentHeight :: !(IORef Int)
115− , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
116− , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
117− }
118−
119−runEventM :: EventM a -> EventEnv -> IO a
120−runEventM = runReaderT . unEventM
121−
122−askToAssignRef :: EventM (IORef [SomeAssignment])
123−askToAssignRef = EventM $ asks eventEnvAssignments
124−
125−askHoldInitRef :: EventM (IORef [SomeHoldInit])
126−askHoldInitRef = EventM $ asks eventEnvHoldInits
127−
128−getCurrentHeight :: EventM Int
129−getCurrentHeight = EventM $ do
130− heightRef <- asks eventEnvCurrentHeight
131− liftIO $ readIORef heightRef
132−
133−putCurrentHeight :: Int -> EventM ()
134−putCurrentHeight h = EventM $ do
135− heightRef <- asks eventEnvCurrentHeight
136− liftIO $ writeIORef heightRef h
137−
138−scheduleClear :: IORef (Maybe a) -> EventM ()
139−scheduleClear r = EventM $ do
140− clears <- asks eventEnvClears
141− liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
142−
143−scheduleRootClear :: IORef (DMap k Identity) -> EventM ()
144−scheduleRootClear r = EventM $ do
145− clears <- asks eventEnvRootClears
146− liftIO $ modifyIORef' clears (SomeDMapIORef r :)
147−
148−scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
149−scheduleMerge height subscribed = EventM $ do
150− delayedRef <- asks eventEnvDelayedMerges
151− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]
152−
153−emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()
154−emitCoincidenceInfo sci = EventM $ do
155− ciRef <- asks eventEnvCoincidenceInfos
156− liftIO $ modifyIORef' ciRef (sci:)
157−
158−-- Note: hold cannot examine its event until after the phase is over
159−hold :: a -> Event a -> EventM (Behavior a)
160−hold v0 e = do
161− holdInitRef <- askHoldInitRef
162− liftIO $ do
163− valRef <- newIORef v0
164− invsRef <- newIORef []
165− parentRef <- newIORef $ error "hold not yet initialized (parent)"
166− subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"
167− let h = Hold
168− { holdValue = valRef
169− , holdInvalidators = invsRef
170− , holdSubscriber = subscriberRef
171− , holdParent = parentRef
172−#ifdef DEBUG_NODEIDS
173− , holdNodeId = unsafeNodeId (v0, e)
174−#endif
175− }
176− s <- newSubscriberHold h
177− writeIORef subscriberRef $ unsafeCoerce s
178− modifyIORef' holdInitRef (SomeHoldInit e h :)
179− return $ BehaviorHold h
180−
181−subscribeHold :: Event a -> Hold a -> EventM ()
182−subscribeHold e h = do
183− toAssignRef <- askToAssignRef
184− !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item
185− ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"
186− subd <- subscribe e $ WeakSubscriberSimple ws
187− liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd
188− occ <- liftIO $ getEventSubscribedOcc subd
189− case occ of
190− Nothing -> return ()
191− Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)
192−
193−--type role BehaviorM representational
194−-- BehaviorM can sample behaviors
195−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
196−
197−data BehaviorSubscribed a
198− = BehaviorSubscribedHold (Hold a)
199− | BehaviorSubscribedPull (PullSubscribed a)
200−
201−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
202−
203−--type role PullSubscribed representational
204−data PullSubscribed a
205− = PullSubscribed { pullSubscribedValue :: !a
206− , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])
207− , pullSubscribedOwnInvalidator :: !Invalidator
208− , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
209− }
210−
211−--type role Pull representational
212−data Pull a
213− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
214− , pullCompute :: !(BehaviorM a)
215− }
216−
217−data Invalidator
218− = forall a. InvalidatorPull (Pull a)
219− | forall a. InvalidatorSwitch (SwitchSubscribed a)
220−
221−data RootSubscribed a
222− = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
223− , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
224− }
225−
226−data Root (k :: * -> *)
227− = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
228− , rootSubscribed :: !(IORef (DMap k RootSubscribed))
229− , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
230− }
231−
232−data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
233−
234−-- EventM can do everything BehaviorM can, plus create holds
235−newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, 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
236−
237−data PushSubscribed a b
238− = PushSubscribed { 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)
239− , pushSubscribedHeight :: !(IORef Int)
240− , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])
241− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die
242− , pushSubscribedParent :: !(EventSubscribed a)
243−#ifdef DEBUG_NODEIDS
244− , pushSubscribedNodeId :: Int
245−#endif
246− }
247−
248−data Push a b
249− = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed
250− , pushParent :: !(Event a)
251− , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
252− }
253−
254−data MergeSubscribed k
255− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
256− , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
257− , mergeSubscribedHeight :: !(IORef Int)
258− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])
259− , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory
260− , mergeSubscribedParents :: !(DMap k EventSubscribed)
261−#ifdef DEBUG_NODEIDS
262− , mergeSubscribedNodeId :: Int
263−#endif
264− }
265−
266−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
267−data Merge k
268− = Merge { mergeParents :: !(DMap k Event)
269− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
270− }
271−
272−data FanSubscriberKey k a where
273− FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]
274−
275−instance GEq k => GEq (FanSubscriberKey k) where
276− geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of
277− Nothing -> Nothing
278− Just Refl -> Just Refl
279−
280−instance GCompare k => GCompare (FanSubscriberKey k) where
281− gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of
282− GLT -> GLT
283− GEQ -> GEQ
284− GGT -> GGT
285−
286−data FanSubscribed k
287− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))
288− , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))
289− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))
290−#ifdef DEBUG_NODEIDS
291− , fanSubscribedNodeId :: Int
292−#endif
293− }
294−
295−data Fan k
296− = Fan { fanParent :: !(Event (DMap k Identity))
297− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
298− }
299−
300−data SwitchSubscribed a
301− = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
302− , switchSubscribedHeight :: !(IORef Int)
303− , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
304− , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
305− , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
306− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
307− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
308− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
309− , switchSubscribedParent :: !(Behavior (Event a))
310− , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))
311−#ifdef DEBUG_NODEIDS
312− , switchSubscribedNodeId :: Int
313−#endif
314− }
315−
316−data Switch a
317− = Switch { switchParent :: !(Behavior (Event a))
318− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
319− }
320−
321−data CoincidenceSubscribed a
322− = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
323− , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
324− , coincidenceSubscribedHeight :: !(IORef Int)
325− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
326− , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
327− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
328−#ifdef DEBUG_NODEIDS
329− , coincidenceSubscribedNodeId :: Int
330−#endif
331− }
332−
333−data Coincidence a
334− = Coincidence { coincidenceParent :: !(Event (Event a))
335− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
336− }
337−
338−data Box a = Box { unBox :: a }
339−
340−--type WeakSubscriber a = Weak (Subscriber a)
341−data WeakSubscriber a
342− = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?
343− | WeakSubscriberSimple !(Weak (Subscriber a))
344−
345−showWeakSubscriberType :: WeakSubscriber a -> String
346−showWeakSubscriberType = \case
347− WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"
348− WeakSubscriberSimple _ -> "WeakSubscriberSimple"
349−
350−deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))
351−deRefWeakSubscriber ws = case ws of
352− WeakSubscriberSimple w -> deRefWeak w
353− WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w
354−
355−data Subscriber a
356− = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)
357− | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
358− | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
359− | SubscriberHold !(Hold a)
360− | SubscriberSwitch (SwitchSubscribed a)
361− | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
362− | SubscriberCoincidenceInner (CoincidenceSubscribed a)
363−
364−showSubscriberType :: Subscriber a -> String
365−showSubscriberType = \case
366− SubscriberPush _ _ -> "SubscriberPush"
367− SubscriberMerge _ _ -> "SubscriberMerge"
368− SubscriberFan _ -> "SubscriberFan"
369− SubscriberHold _ -> "SubscriberHold"
370− SubscriberSwitch _ -> "SubscriberSwitch"
371− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
372− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
373−
374−data Event a
375− = forall k. GCompare k => EventRoot !(k a) !(Root k)
376− | EventNever
377− | forall b. EventPush !(Push b a)
378− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
379− | forall k. GCompare k => EventFan !(k a) !(Fan k)
380− | EventSwitch !(Switch a)
381− | EventCoincidence !(Coincidence a)
382−
383−showEventType :: Event a -> String
384−showEventType = \case
385− EventRoot _ _ -> "EventRoot"
386− EventNever -> "EventNever"
387− EventPush _ -> "EventPush"
388− EventMerge _ -> "EventMerge"
389− EventFan _ _ -> "EventFan"
390− EventSwitch _ -> "EventSwitch"
391− EventCoincidence _ -> "EventCoincidence"
392−
393−data EventSubscribed a
394− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
395− | EventSubscribedNever
396− | forall b. EventSubscribedPush !(PushSubscribed b a)
397− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
398− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
399− | EventSubscribedSwitch !(SwitchSubscribed a)
400− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
401−
402−-- These function are constructor functions that are marked NOINLINE so they are
403−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
404−-- so any weak references that are attached to the constructors will have their
405−-- finalizer run. Using the opaque constructor, does not see the
406−-- constructor application, so it behaves like an IORef and cannot be fused away.
407−--
408−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
409−-- the weak pointer to it in some cases.
410−
411−{-# NOINLINE newRootSubscribed #-}
412−newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
413−newRootSubscribed occ subs =
414− return $! RootSubscribed
415− { rootSubscribedOccurrence = occ
416− , rootSubscribedSubscribers = subs
417− }
418−
419−{-# NOINLINE newSubscriberPush #-}
420−newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
421−newSubscriberPush compute subd = return $! SubscriberPush compute subd
422−
423−{-# NOINLINE newSubscriberHold #-}
424−newSubscriberHold :: Hold a -> IO (Subscriber a)
425−newSubscriberHold h = return $! SubscriberHold h
426−
427−{-# NOINLINE newSubscriberFan #-}
428−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
429−newSubscriberFan subd = return $! SubscriberFan subd
430−
431−{-# NOINLINE newSubscriberSwitch #-}
432−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
433−newSubscriberSwitch subd = return $! SubscriberSwitch subd
434−
435−{-# NOINLINE newSubscriberCoincidenceOuter #-}
436−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
437−newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
438−
439−{-# NOINLINE newSubscriberCoincidenceInner #-}
440−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
441−newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
442−
443−{-# NOINLINE newInvalidatorSwitch #-}
444−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
445−newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
446−
447−{-# NOINLINE newInvalidatorPull #-}
448−newInvalidatorPull :: Pull a -> IO Invalidator
449−newInvalidatorPull p = return $! InvalidatorPull p
450−
451−{-# NOINLINE newBox #-}
452−newBox :: a -> IO (Box a)
453−newBox a = return $! Box a
454−
455−--type role Behavior representational
456−data Behavior a
457− = BehaviorHold !(Hold a)
458− | BehaviorConst !a
459− | BehaviorPull !(Pull a)
460−
461−-- ResultM can read behaviors and events
462−type ResultM = EventM
463−
464−{-# NOINLINE unsafeNewIORef #-}
465−unsafeNewIORef :: a -> b -> IORef b
466−unsafeNewIORef _ b = unsafePerformIO $ newIORef b
467−
468−instance Functor Event where
469− fmap f = push $ return . Just . f
470−
471−instance Functor Behavior where
472− fmap f = pull . liftM f . readBehaviorTracked
473−
474−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
475−push :: (a -> EventM (Maybe b)) -> Event a -> Event b
476−push f e = EventPush $ Push
477− { pushCompute = f
478− , pushParent = e
479− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
480− }
481−{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
482−
483−{-# NOINLINE pull #-}
484−pull :: BehaviorM a -> Behavior a
485−pull a = BehaviorPull $ Pull
486− { pullCompute = a
487− , pullValue = unsafeNewIORef a Nothing
488− }
489−{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}
490−
491−{-# NOINLINE switch #-}
492−switch :: Behavior (Event a) -> Event a
493−switch a = EventSwitch $ Switch
494− { switchParent = a
495− , switchSubscribed = unsafeNewIORef a Nothing
496− }
497−{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}
498−
499−coincidence :: Event (Event a) -> Event a
500−coincidence a = EventCoincidence $ Coincidence
501− { coincidenceParent = a
502− , coincidenceSubscribed = unsafeNewIORef a Nothing
503− }
504−
505−newRoot :: IO (Root k)
506−newRoot = do
507− occRef <- newIORef DMap.empty
508− subscribedRef <- newIORef DMap.empty
509− return $ Root
510− { rootOccurrence = occRef
511− , rootSubscribed = subscribedRef
512− , rootInit = \_ _ -> return $ return ()
513− }
514−
515−propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
516−propagateAndUpdateSubscribersRef subscribersRef a = do
517− subscribers <- liftIO $ readIORef subscribersRef
518− liftIO $ writeIORef subscribersRef []
519− stillAlive <- propagate a subscribers
520− liftIO $ modifyIORef' subscribersRef (++stillAlive)
521−
522−-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
523−run :: [DSum RootTrigger Identity] -> ResultM b -> IO b
524−run roots after = do
525− when debugPropagate $ putStrLn "Running an event frame"
526− result <- runFrame $ do
527− rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
528− occBefore <- liftIO $ do
529− occBefore <- readIORef occRef
530− writeIORef occRef $ DMap.insert k a occBefore
531− return occBefore
532− if DMap.null occBefore
533− then do scheduleRootClear occRef
534− return $ Just r
535− else return Nothing
536− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
537− propagateAndUpdateSubscribersRef subscribersRef a
538− delayedRef <- EventM $ asks eventEnvDelayedMerges
539− let go = do
540− delayed <- liftIO $ readIORef delayedRef
541− case IntMap.minViewWithKey delayed of
542− Nothing -> return ()
543− Just ((currentHeight, current), future) -> do
544− when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight
545− putCurrentHeight currentHeight
546− liftIO $ writeIORef delayedRef future
547− forM_ current $ \d -> case d of
548− DelayedMerge subscribed -> do
549− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
550− case height `compare` currentHeight of
551− LT -> error "Somehow a merge's height has been decreased after it was scheduled"
552− GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
553− EQ -> do
554− m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
555− liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty
556− --TODO: Assert that m is not empty
557− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m
558− scheduleClear $ mergeSubscribedOccurrence subscribed
559− propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
560− go
561− go
562− putCurrentHeight maxBound
563− after
564− when debugPropagate $ putStrLn "Done running an event frame"
565− return result
566−
567−data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
568−
569−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))
570−
571−data SomeAssignment = forall a. SomeAssignment (Hold a) a
572−
573−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
574−
575−debugFinalize :: Bool
576−debugFinalize = False
577−
578−mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
579−mkWeakPtrWithDebug x debugNote = mkWeakPtr x $
580− if debugFinalize
581− then Just $ putStrLn $ "finalizing: " ++ debugNote
582− else Nothing
583−
584−type WeakList a = [Weak a]
585−
586−--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?
587−traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]
588−traverseAndCleanWeakList_ deRef ws f = go ws
589− where go [] = return []
590− go (h:t) = do
591− ma <- deRef h
592− case ma of
593− Just a -> do
594− f a
595− t' <- go t
596− return $ h : t'
597− Nothing -> go t
598−
599−-- | Propagate everything at the current height
600−propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
601−propagate a subscribers = do
602− traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
603− SubscriberPush compute subscribed -> do
604− when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
605− occ <- compute a
606− case occ of
607− Nothing -> return () -- No need to write a Nothing back into the Ref
608− Just o -> do
609− liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
610− scheduleClear $ pushSubscribedOccurrence subscribed
611− liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
612− SubscriberMerge k subscribed -> do
613− when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
614− oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
615− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM
616− when (DMap.null oldM) $ do -- Only schedule the firing once
617− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
618− --TODO: assertions about height
619− currentHeight <- getCurrentHeight
620− when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
621− scheduleMerge height subscribed
622− SubscriberFan subscribed -> do
623− subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
624− when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
625− --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
626− forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of
627− Nothing -> do
628− when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
629− return ()
630− Just (Identity subsubs) -> do
631− _ <- propagate v subsubs --TODO: use the value of this
632− return ()
633− --TODO: The following is way too slow to do all the time
634− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do
635− subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
636− return $ if null subsubs'
637− then Nothing
638− else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))
639− liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
640− SubscriberHold h -> do
641− invalidators <- liftIO $ readIORef $ holdInvalidators h
642− when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
643− toAssignRef <- askToAssignRef
644− liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
645− SubscriberSwitch subscribed -> do
646− when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
647− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
648− scheduleClear $ switchSubscribedOccurrence subscribed
649− subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
650− liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
651− SubscriberCoincidenceOuter subscribed -> do
652− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
653− outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
654− when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
655− (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
656− when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ)
657− when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight
658− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
659− scheduleClear $ coincidenceSubscribedInnerParent subscribed
660− case occ of
661− Nothing -> do
662− when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
663− writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
664− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
665− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
666− Just o -> do -- Since it's already firing, no need to adjust height
667− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
668− scheduleClear $ coincidenceSubscribedOccurrence subscribed
669− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
670− SubscriberCoincidenceInner subscribed -> do
671− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
672− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
673− scheduleClear $ coincidenceSubscribedOccurrence subscribed
674− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
675−
676−data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
677−
678−subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
679−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
680− subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
681− wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
682− innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
683− innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
684− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
685− let height = max innerHeight outerHeight
686− emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing
687− return (innerOcc, height, innerSubd)
688−
689−readBehavior :: Behavior a -> IO a
690−readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
691−
692−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a
693−runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi
694−
695−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
696−askInvalidator = liftM (fmap fst) $ BehaviorM ask
697−
698−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
699−askParentsRef = liftM (fmap snd) $ BehaviorM ask
700−
701−readBehaviorTracked :: Behavior a -> BehaviorM a
702−readBehaviorTracked b = case b of
703− BehaviorHold h -> do
704− result <- liftIO $ readIORef $ holdValue h
705− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
706− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
707− liftIO $ touch $ holdSubscriber h
708− return result
709− BehaviorConst a -> return a
710− BehaviorPull p -> do
711− val <- liftIO $ readIORef $ pullValue p
712− case val of
713− Just subscribed -> do
714− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
715− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
716− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
717− return $ pullSubscribedValue subscribed
718− Nothing -> do
719− i <- liftIO $ newInvalidatorPull p
720− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
721− parentsRef <- liftIO $ newIORef []
722− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
723− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
724− parents <- liftIO $ readIORef parentsRef
725− let subscribed = PullSubscribed
726− { pullSubscribedValue = a
727− , pullSubscribedInvalidators = invsRef
728− , pullSubscribedOwnInvalidator = i
729− , pullSubscribedParents = parents
730− }
731− liftIO $ writeIORef (pullValue p) $ Just subscribed
732− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
733− return a
734−
735−readEvent :: Event a -> ResultM (Maybe a)
736−readEvent e = case e of
737− EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
738− EventNever -> return Nothing
739− EventPush p -> do
740− subscribed <- getPushSubscribed p
741− liftIO $ do
742− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
743− touch $ pushSubscribedSelf subscribed
744− return result
745− EventMerge m -> do
746− subscribed <- getMergeSubscribed m
747− liftIO $ do
748− result <- readIORef $ mergeSubscribedOccurrence subscribed
749− touch $ mergeSubscribedSelf subscribed
750− return result
751− EventFan k f -> do
752− parentOcc <- readEvent $ fanParent f
753− return . coerce $ DMap.lookup k =<< parentOcc
754− EventSwitch s -> do
755− subscribed <- getSwitchSubscribed s
756− liftIO $ do
757− result <- readIORef $ switchSubscribedOccurrence subscribed
758− touch $ switchSubscribedSelf subscribed
759− touch $ switchSubscribedOwnInvalidator subscribed
760− return result
761− EventCoincidence c -> do
762− subscribed <- getCoincidenceSubscribed c
763− liftIO $ do
764− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
765− touch $ coincidenceSubscribedOuter subscribed
766− --TODO: do we need to touch the inner subscriber?
767− return result
768−
769−-- Always refers to 0
770−{-# NOINLINE zeroRef #-}
771−zeroRef :: IORef Int
772−zeroRef = unsafePerformIO $ newIORef 0
773−
774−getEventSubscribed :: Event a -> EventM (EventSubscribed a)
775−getEventSubscribed e = case e of
776− EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
777− EventNever -> return EventSubscribedNever
778− EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
779− EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
780− EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m
781− EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s
782− EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c
783−
784−debugSubscribe :: Bool
785−debugSubscribe = False
786−
787−subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()
788−subscribeEventSubscribed es ws = case es of
789− EventSubscribedRoot r -> do
790− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"
791− modifyIORef' (rootSubscribedSubscribers r) (ws:)
792− EventSubscribedNever -> do
793− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"
794− return ()
795− EventSubscribedPush subscribed -> do
796− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"
797− modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
798− EventSubscribedFan k subscribed -> do
799− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
800− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])
801− EventSubscribedMerge subscribed -> do
802− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
803− modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
804− EventSubscribedSwitch subscribed -> do
805− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"
806− modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)
807− EventSubscribedCoincidence subscribed -> do
808− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"
809− modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)
810−
811−getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
812−getEventSubscribedOcc es = case es of
813− EventSubscribedRoot r -> rootSubscribedOccurrence r
814− EventSubscribedNever -> return Nothing
815− EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
816− EventSubscribedFan k subscribed -> do
817− parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
818− let occ = coerce $ DMap.lookup k =<< parentOcc
819− return occ
820− EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
821− EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
822− EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed
823−
824−eventSubscribedHeightRef :: EventSubscribed a -> IORef Int
825−eventSubscribedHeightRef es = case es of
826− EventSubscribedRoot _ -> zeroRef
827− EventSubscribedNever -> zeroRef
828− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
829− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed
830− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
831− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
832− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
833−
834−subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)
835−subscribe e ws = do
836− subd <- getEventSubscribed e
837− liftIO $ subscribeEventSubscribed subd ws
838− return subd
839−
840−noinlineFalse :: Bool
841−noinlineFalse = False
842−{-# NOINLINE noinlineFalse #-}
843−
844−getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
845−getRootSubscribed k r = do
846− mSubscribed <- liftIO $ readIORef $ rootSubscribed r
847− case DMap.lookup k mSubscribed of
848− Just subscribed -> return subscribed
849− Nothing -> liftIO $ do
850− subscribersRef <- newIORef []
851− subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
852− -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
853− uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
854− addFinalizer subscribed $ do
855− when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
856−-- putStrLn "Uninit root"
857− uninit
858− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed
859− return subscribed
860−
861−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
862−getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)
863−getPushSubscribed p = do
864− mSubscribed <- liftIO $ readIORef $ pushSubscribed p
865− case mSubscribed of
866− Just subscribed -> return subscribed
867− Nothing -> do -- Not yet subscribed
868− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
869− s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
870− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
871− subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
872− parentOcc <- liftIO $ getEventSubscribedOcc subd
873− occ <- liftM join $ mapM (pushCompute p) parentOcc
874− occRef <- liftIO $ newIORef occ
875− when (isJust occ) $ scheduleClear occRef
876− subscribersRef <- liftIO $ newIORef []
877− let subscribed = PushSubscribed
878− { pushSubscribedOccurrence = occRef
879− , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
880− , pushSubscribedSubscribers = subscribersRef
881− , pushSubscribedSelf = unsafeCoerce s
882− , pushSubscribedParent = subd
883−#ifdef DEBUG_NODEIDS
884− , pushSubscribedNodeId = unsafeNodeId p
885−#endif
886− }
887− liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
888− return subscribed
889−
890−getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)
891−getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
892− mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
893− case mSubscribed of
894− Just subscribed -> return subscribed
895− Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
896− subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
897− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
898− s <- liftIO $ newBox subscribedUnsafe
899− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
900− subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
901− parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
902− parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
903− height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
904− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd)
905− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers
906− subscriberHeights = map (\(_, _, x, _) -> x) subscribers
907− myHeight =
908− if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
909− then invalidHeight
910− else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here
911− currentHeight <- getCurrentHeight
912− let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
913− then (if DMap.null dm then Nothing else Just dm, DMap.empty)
914− else (Nothing, dm)
915− when (not $ DMap.null accum) $ do
916− scheduleMerge myHeight subscribedUnsafe
917− occRef <- liftIO $ newIORef occ
918− when (isJust occ) $ scheduleClear occRef
919− accumRef <- liftIO $ newIORef accum
920− heightRef <- liftIO $ newIORef myHeight
921− subsRef <- liftIO $ newIORef []
922− let subscribed = MergeSubscribed
923− { mergeSubscribedOccurrence = occRef
924− , mergeSubscribedAccum = accumRef
925− , mergeSubscribedHeight = heightRef
926− , mergeSubscribedSubscribers = subsRef
927− , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?
928− , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers
929−#ifdef DEBUG_NODEIDS
930− , mergeSubscribedNodeId = unsafeNodeId m
931−#endif
932− }
933− liftIO $ writeIORef subscribedRef subscribed
934− return subscribed
935− where emptyMergeSubscribed = do --TODO: This should never happen
936− occRef <- liftIO $ newIORef Nothing
937− accumRef <- liftIO $ newIORef DMap.empty
938− subsRef <- liftIO $ newIORef []
939− return $ MergeSubscribed
940− { mergeSubscribedOccurrence = occRef
941− , mergeSubscribedAccum = accumRef
942− , mergeSubscribedHeight = zeroRef
943− , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak
944− , mergeSubscribedSelf = unsafeCoerce ()
945− , mergeSubscribedParents = DMap.empty
946−#ifdef DEBUG_NODEIDS
947− , mergeSubscribedNodeId = -1
948−#endif
949− }
950−
951−getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)
952−getFanSubscribed f = do
953− mSubscribed <- liftIO $ readIORef $ fanSubscribed f
954− case mSubscribed of
955− Just subscribed -> return subscribed
956− Nothing -> do
957− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
958− sub <- liftIO $ newSubscriberFan subscribedUnsafe
959− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
960− subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
961− subscribersRef <- liftIO $ newIORef DMap.empty
962− let subscribed = FanSubscribed
963− { fanSubscribedParent = subd
964− , fanSubscribedSubscribers = subscribersRef
965− , fanSubscribedSelf = sub
966−#ifdef DEBUG_NODEIDS
967− , fanSubscribedNodeId = unsafeNodeId f
968−#endif
969− }
970− liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
971− return subscribed
972−
973−getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)
974−getSwitchSubscribed s = do
975− mSubscribed <- liftIO $ readIORef $ switchSubscribed s
976− case mSubscribed of
977− Just subscribed -> return subscribed
978− Nothing -> do
979− subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
980− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
981− i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
982− sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
983− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
984− wiRef <- liftIO $ newIORef wi
985− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
986− selfWeakRef <- liftIO $ newIORef wsub
987− parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
988− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)
989− subd <- subscribe e $ WeakSubscriberSimple wsub
990− subdRef <- liftIO $ newIORef subd
991− parentOcc <- liftIO $ getEventSubscribedOcc subd
992− occRef <- liftIO $ newIORef parentOcc
993− when (isJust parentOcc) $ scheduleClear occRef
994− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
995− subscribersRef <- liftIO $ newIORef []
996− let subscribed = SwitchSubscribed
997− { switchSubscribedOccurrence = occRef
998− , switchSubscribedHeight = heightRef
999− , switchSubscribedSubscribers = subscribersRef
1000− , switchSubscribedSelf = sub
1001− , switchSubscribedSelfWeak = selfWeakRef
1002− , switchSubscribedOwnInvalidator = i
1003− , switchSubscribedOwnWeakInvalidator = wiRef
1004− , switchSubscribedBehaviorParents = parentsRef
1005− , switchSubscribedParent = switchParent s
1006− , switchSubscribedCurrentParent = subdRef
1007−#ifdef DEBUG_NODEIDS
1008− , switchSubscribedNodeId = unsafeNodeId s
1009−#endif
1010− }
1011− liftIO $ writeIORef subscribedRef subscribed
1012− liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1013− return subscribed
1014−
1015−getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)
1016−getCoincidenceSubscribed c = do
1017− mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1018− case mSubscribed of
1019− Just subscribed -> return subscribed
1020− Nothing -> do
1021− subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1022− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1023− subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1024− wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
1025− outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
1026− outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
1027− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1028− (occ, height, mInnerSubd) <- case outerOcc of
1029− Nothing -> return (Nothing, outerHeight, Nothing)
1030− Just o -> do
1031− (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1032− return (occ, height, Just innerSubd)
1033− occRef <- liftIO $ newIORef occ
1034− when (isJust occ) $ scheduleClear occRef
1035− heightRef <- liftIO $ newIORef height
1036− innerSubdRef <- liftIO $ newIORef mInnerSubd
1037− scheduleClear innerSubdRef
1038− subscribersRef <- liftIO $ newIORef []
1039− let subscribed = CoincidenceSubscribed
1040− { coincidenceSubscribedOccurrence = occRef
1041− , coincidenceSubscribedHeight = heightRef
1042− , coincidenceSubscribedSubscribers = subscribersRef
1043− , coincidenceSubscribedOuter = subOuter
1044− , coincidenceSubscribedOuterParent = outerSubd
1045− , coincidenceSubscribedInnerParent = innerSubdRef
1046−#ifdef DEBUG_NODEIDS
1047− , coincidenceSubscribedNodeId = unsafeNodeId c
1048−#endif
1049− }
1050− liftIO $ writeIORef subscribedRef subscribed
1051− liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1052− return subscribed
1053−
1054−merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
1055−merge m = EventMerge $ Merge
1056− { mergeParents = m
1057− , mergeSubscribed = unsafeNewIORef m Nothing
1058− }
1059−
1060−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1061−
1062−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1063−fan e =
1064− let f = Fan
1065− { fanParent = e
1066− , fanSubscribed = unsafeNewIORef e Nothing
1067− }
1068− in EventSelector $ \k -> EventFan k f
1069−
1070−-- | Run an event action outside of a frame
1071−runFrame :: EventM a -> IO a
1072−runFrame a = do
1073− toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1074− holdInitRef <- newIORef []
1075− heightRef <- newIORef 0
1076− toClearRef <- newIORef []
1077− toClearRootRef <- newIORef []
1078− coincidenceInfosRef <- newIORef []
1079− delayedRef <- liftIO $ newIORef IntMap.empty
1080− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
1081− result <- a
1082− let runHoldInits = do
1083− holdInits <- liftIO $ readIORef holdInitRef
1084− if null holdInits then return () else do
1085− liftIO $ writeIORef holdInitRef []
1086− forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h
1087− runHoldInits
1088− runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1089− return result
1090− toClear <- readIORef toClearRef
1091− forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1092− toClearRoot <- readIORef toClearRootRef
1093− forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
1094− toAssign <- readIORef toAssignRef
1095− toReconnectRef <- newIORef []
1096− forM_ toAssign $ \(SomeAssignment h v) -> do
1097− writeIORef (holdValue h) v
1098− writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)
1099− coincidenceInfos <- readIORef coincidenceInfosRef
1100− forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do
1101− touch subInner
1102− finalize wsubInner
1103− mapM_ invalidateCoincidenceHeight mcs
1104− toReconnect <- readIORef toReconnectRef
1105− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1106− wsub <- readIORef $ switchSubscribedSelfWeak subscribed
1107− finalize wsub
1108− wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1109− finalize wi
1110− let !i = switchSubscribedOwnInvalidator subscribed
1111− wi' <- mkWeakPtrWithDebug i "wi'"
1112− writeIORef (switchSubscribedBehaviorParents subscribed) []
1113− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))
1114− --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1115− let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk
1116− wsub' <- mkWeakPtrWithDebug sub "wsub'"
1117− writeIORef (switchSubscribedSelfWeak subscribed) wsub'
1118− subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --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
1119− {-
1120− stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1121− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1122− EventRoot _ -> "EventRoot"
1123− EventNever -> "EventNever"
1124− _ -> "something else"
1125− -}
1126− writeIORef (switchSubscribedCurrentParent subscribed) subd'
1127− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1128− myHeight <- readIORef $ switchSubscribedHeight subscribed
1129− if parentHeight == myHeight then return () else do
1130− writeIORef (switchSubscribedHeight subscribed) parentHeight
1131− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1132− forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1133− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1134− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1135− return result
1136−
1137−invalidHeight :: Int
1138−invalidHeight = -1000
1139−
1140−invalidateSubscriberHeight :: WeakSubscriber a -> IO ()
1141−invalidateSubscriberHeight ws = do
1142− ms <- deRefWeakSubscriber ws
1143− case ms of
1144− Nothing -> return () --TODO: cleanup?
1145− Just s -> case s of
1146− SubscriberPush _ subscribed -> do
1147− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1148− mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1149− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1150− SubscriberMerge _ subscribed -> do
1151− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1152− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1153− when (oldHeight /= invalidHeight) $ do
1154− writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight
1155− mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1156− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1157− SubscriberFan subscribed -> do
1158− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1159− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1160− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1161− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1162− SubscriberHold _ -> return ()
1163− SubscriberSwitch subscribed -> do
1164− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1165− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1166− when (oldHeight /= invalidHeight) $ do
1167− writeIORef (switchSubscribedHeight subscribed) $ invalidHeight
1168− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1169− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1170− SubscriberCoincidenceOuter subscribed -> do
1171− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1172− invalidateCoincidenceHeight subscribed
1173− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1174− SubscriberCoincidenceInner subscribed -> do
1175− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1176− invalidateCoincidenceHeight subscribed
1177− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1178−
1179−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1180−invalidateCoincidenceHeight subscribed = do
1181− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1182− when (oldHeight /= invalidHeight) $ do
1183− writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight
1184− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
1185−
1186−--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1187−
1188−recalculateSubscriberHeight :: WeakSubscriber a -> IO ()
1189−recalculateSubscriberHeight ws = do
1190− ms <- deRefWeakSubscriber ws
1191− case ms of
1192− Nothing -> return () --TODO: cleanup?
1193− Just s -> case s of
1194− SubscriberPush _ subscribed -> do
1195− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1196− mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1197− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1198− SubscriberMerge _ subscribed -> do
1199− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1200− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1201− when (oldHeight == invalidHeight) $ do
1202− height <- calculateMergeHeight subscribed
1203− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1204− when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1205− writeIORef (mergeSubscribedHeight subscribed) height
1206− mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1207− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1208− SubscriberFan subscribed -> do
1209− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1210− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1211− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1212− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1213− SubscriberHold _ -> return ()
1214− SubscriberSwitch subscribed -> do
1215− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1216− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1217− when (oldHeight == invalidHeight) $ do
1218− height <- calculateSwitchHeight subscribed
1219− when (height /= invalidHeight) $ do
1220− writeIORef (switchSubscribedHeight subscribed) height
1221− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1222− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1223− SubscriberCoincidenceOuter subscribed -> do
1224− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1225− void $ recalculateCoincidenceHeight subscribed
1226− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1227− SubscriberCoincidenceInner subscribed -> do
1228− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1229− void $ recalculateCoincidenceHeight subscribed
1230− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1231−
1232−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1233−recalculateCoincidenceHeight subscribed = do
1234− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1235− when (oldHeight == invalidHeight) $ do
1236− height <- calculateCoincidenceHeight subscribed
1237− when (height /= invalidHeight) $ do
1238− writeIORef (coincidenceSubscribedHeight subscribed) height
1239− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones
1240−
1241−calculateMergeHeight :: MergeSubscribed k -> IO Int
1242−calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1243− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do
1244− readIORef $ eventSubscribedHeightRef es
1245− return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
1246−
1247−calculateSwitchHeight :: SwitchSubscribed a -> IO Int
1248−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)
1249−
1250−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int
1251−calculateCoincidenceHeight subscribed = do
1252− outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed
1253− innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1254− return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1255−
1256−{-
1257−recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int
1258−recalculateEventSubscribedHeight es = case es of
1259− EventSubscribedRoot _ -> return 0
1260− EventSubscribedNever -> return 0
1261− EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed
1262− EventSubscribedMerge subscribed -> do
1263− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1264− if oldHeight /= invalidHeight then return oldHeight else do
1265− height <- calculateMergeHeight subscribed
1266− writeIORef (mergeSubscribedHeight subscribed) height
1267− return height
1268− EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed
1269− EventSubscribedSwitch subscribed -> do
1270− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1271− if oldHeight /= invalidHeight then return oldHeight else do
1272− height <- calculateSwitchHeight subscribed
1273− writeIORef (switchSubscribedHeight subscribed) height
1274− return height
1275− EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed
1276−-}
1277−
1278−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)
1279−
1280−debugInvalidate :: Bool
1281−debugInvalidate = False
1282−
1283−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1284−invalidate toReconnectRef wis = do
1285− forM_ wis $ \wi -> do
1286− mi <- deRefWeak wi
1287− case mi of
1288− Nothing -> do
1289− when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"
1290− return () --TODO: Should we clean this up here?
1291− Just i -> do
1292− finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1293− case i of
1294− InvalidatorPull p -> do
1295− when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"
1296− mVal <- readIORef $ pullValue p
1297− forM_ mVal $ \val -> do
1298− writeIORef (pullValue p) Nothing
1299− writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1300− InvalidatorSwitch subscribed -> do
1301− when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"
1302− modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1303− 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
1304−
1305−--------------------------------------------------------------------------------
1306−-- Reflex integration
1307−--------------------------------------------------------------------------------
1308−
1309−data Spider
1310−
1311−instance R.Reflex Spider where
1312− newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1313− newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }
1314− type PullM Spider = BehaviorM
1315− type PushM Spider = EventM
1316− {-# INLINE never #-}
1317− {-# INLINE constant #-}
1318− never = SpiderEvent EventNever
1319− constant = SpiderBehavior . BehaviorConst
1320− push f = SpiderEvent. push f . unSpiderEvent
1321− pull = SpiderBehavior . pull
1322− merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)
1323− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1324− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
1325− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
1326−
1327−instance R.MonadSample Spider SpiderHost where
1328− {-# INLINE sample #-}
1329− sample = SpiderHost . readBehavior . unSpiderBehavior
1330−
1331−instance R.MonadHold Spider SpiderHost where
1332− hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent
1333−
1334−instance R.MonadSample Spider BehaviorM where
1335− {-# INLINE sample #-}
1336− sample = readBehaviorTracked . unSpiderBehavior
1337−
1338−instance R.MonadSample Spider EventM where
1339− {-# INLINE sample #-}
1340− sample = liftIO . readBehavior . unSpiderBehavior
1341−
1342−instance R.MonadHold Spider EventM where
1343− {-# INLINE hold #-}
1344− hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
1345−
1346−data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)
1347−newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
1348−
1349−instance R.MonadSubscribeEvent Spider SpiderHostFrame where
1350− subscribeEvent e = SpiderHostFrame $ do
1351− _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1352− return $ SpiderEventHandle (unSpiderEvent e)
1353−
1354−instance R.ReflexHost Spider where
1355− type EventTrigger Spider = RootTrigger
1356− type EventHandle Spider = SpiderEventHandle
1357− type HostFrame Spider = SpiderHostFrame
1358−
1359−instance R.MonadReadEvent Spider ReadPhase where
1360− {-# INLINE readEvent #-}
1361− readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle
1362−
1363−instance MonadRef EventM where
1364− type Ref EventM = Ref IO
1365− {-# INLINE newRef #-}
1366− {-# INLINE readRef #-}
1367− {-# INLINE writeRef #-}
1368− newRef = liftIO . newRef
1369− readRef = liftIO . readRef
1370− writeRef r a = liftIO $ writeRef r a
1371−
1372−instance MonadAtomicRef EventM where
1373− {-# INLINE atomicModifyRef #-}
1374− atomicModifyRef r f = liftIO $ atomicModifyRef r f
1375−
1376−newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1377−
1378−newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1379−
1380−instance R.MonadSample Spider SpiderHostFrame where
1381− sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can
1382−
1383−instance R.MonadHold Spider SpiderHostFrame where
1384− {-# INLINE hold #-}
1385− hold v0 e = SpiderHostFrame $ R.hold v0 e
1386−
1387−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
1388−newEventWithTriggerIO f = do
1389− es <- newFanEventWithTriggerIO $ \Refl -> f
1390− return $ select es Refl
1391−
1392−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
1393−newFanEventWithTriggerIO f = do
1394− occRef <- newIORef DMap.empty
1395− subscribedRef <- newIORef DMap.empty
1396− let !r = Root
1397− { rootOccurrence = occRef
1398− , rootSubscribed = subscribedRef
1399− , rootInit = f
1400− }
1401− return $ EventSelector $ \k -> EventRoot k r
1402−
1403−instance R.MonadReflexCreateTrigger Spider SpiderHost where
1404− newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
1405− newFanEventWithTrigger f = SpiderHost $ do
1406− es <- newFanEventWithTriggerIO f
1407− return $ R.EventSelector $ SpiderEvent . select es
1408−
1409−instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
1410− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
1411− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
1412− es <- newFanEventWithTriggerIO f
1413− return $ R.EventSelector $ SpiderEvent . select es
1414−
1415−instance R.MonadSubscribeEvent Spider SpiderHost where
1416− subscribeEvent e = SpiderHost $ do
1417− _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1418− return $ SpiderEventHandle (unSpiderEvent e)
1419−
1420−newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)
1421−
1422−instance R.MonadReflexHost Spider SpiderHost where
1423− type ReadPhase SpiderHost = ReadPhase
1424− fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a
1425− runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
1426−
1427−instance MonadRef SpiderHost where
1428− type Ref SpiderHost = Ref IO
1429− newRef = SpiderHost . newRef
1430− readRef = SpiderHost . readRef
1431− writeRef r = SpiderHost . writeRef r
1432−
1433−instance MonadAtomicRef SpiderHost where
1434− atomicModifyRef r = SpiderHost . atomicModifyRef r
1435−
1436−instance MonadRef SpiderHostFrame where
1437− type Ref SpiderHostFrame = Ref IO
1438− newRef = SpiderHostFrame . newRef
1439− readRef = SpiderHostFrame . readRef
1440− writeRef r = SpiderHostFrame . writeRef r
1441−
1442−instance MonadAtomicRef SpiderHostFrame where
1443− atomicModifyRef r = SpiderHostFrame . atomicModifyRef r