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