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