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