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