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