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