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