@@ -1,1346 +0,0 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}
2−module Reflex.Spider.Internal where
4−import Prelude hiding (mapM, mapM_, any, sequence, concat)
6−import qualified Reflex.Class as R
7−import qualified Reflex.Host.Class as R
10−import System.Mem.Weak
12−import Data.Traversable
13−import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
14−import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
16−import Control.Applicative
17−import Data.Dependent.Map (DMap, DSum (..))
18−import qualified Data.Dependent.Map as DMap
19−import Data.GADT.Compare
20−import Data.Functor.Misc
22−import Data.IntMap (IntMap)
23−import qualified Data.IntMap as IntMap
24−import Control.Lens hiding (coerce)
25−import Control.Monad.TypedId
26−import Control.Monad.Ref
27−import Data.Monoid ((<>))
29−import System.IO.Unsafe
31−import Control.Monad.Primitive
33−debugPropagate :: Bool
35−debugInvalidateHeight :: Bool
43−debugInvalidateHeight = True
45−class HasNodeId a where
46− getNodeId :: a -> Int
48−instance HasNodeId (Hold a) where
49− getNodeId = holdNodeId
51−instance HasNodeId (PushSubscribed a b) where
52− getNodeId = pushSubscribedNodeId
54−instance HasNodeId (SwitchSubscribed a) where
55− getNodeId = switchSubscribedNodeId
57−instance HasNodeId (MergeSubscribed a) where
58− getNodeId = mergeSubscribedNodeId
60−instance HasNodeId (FanSubscribed a) where
61− getNodeId = fanSubscribedNodeId
63−instance HasNodeId (CoincidenceSubscribed a) where
64− getNodeId = coincidenceSubscribedNodeId
66−instance HasNodeId (RootSubscribed a) where
67− getNodeId = rootSubscribedNodeId
69−showNodeId :: HasNodeId a => a -> String
70−showNodeId = ("#"<>) . show . getNodeId
74−debugPropagate = False
76−debugInvalidateHeight = False
78−showNodeId :: a -> String
84−{-# NOINLINE nextNodeIdRef #-}
85−nextNodeIdRef :: IORef Int
86−nextNodeIdRef = unsafePerformIO $ newIORef 1
88−{-# NOINLINE unsafeNodeId #-}
89−unsafeNodeId :: a -> Int
90−unsafeNodeId a = unsafePerformIO $ do
92− atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
95−--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
96−--type role Hold representational
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
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]))
117−runEventM :: EventM a -> EventEnv -> IO a
118−runEventM = runReaderT . unEventM
120−askToAssignRef :: EventM (IORef [SomeAssignment])
121−askToAssignRef = EventM $ asks eventEnvAssignments
123−askHoldInitRef :: EventM (IORef [SomeHoldInit])
124−askHoldInitRef = EventM $ asks eventEnvHoldInits
126−getCurrentHeight :: EventM Int
127−getCurrentHeight = EventM $ do
128− heightRef <- asks eventEnvCurrentHeight
129− liftIO $ readIORef heightRef
131−putCurrentHeight :: Int -> EventM ()
132−putCurrentHeight h = EventM $ do
133− heightRef <- asks eventEnvCurrentHeight
134− liftIO $ writeIORef heightRef h
136−scheduleClear :: IORef (Maybe a) -> EventM ()
137−scheduleClear r = EventM $ do
138− clears <- asks eventEnvClears
139− liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
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]
146−emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()
147−emitCoincidenceInfo sci = EventM $ do
148− ciRef <- asks eventEnvCoincidenceInfos
149− liftIO $ modifyIORef' ciRef (sci:)
151−-- Note: hold cannot examine its event until after the phase is over
152−hold :: a -> Event a -> EventM (Behavior a)
154− holdInitRef <- askHoldInitRef
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)"
161− { holdValue = valRef
162− , holdInvalidators = invsRef
163− , holdSubscriber = subscriberRef
164− , holdParent = parentRef
166− , holdNodeId = unsafeNodeId (v0, e)
169− !s = SubscriberHold h
170− writeIORef subscriberRef $ unsafeCoerce s
171− modifyIORef' holdInitRef (SomeHoldInit e h :)
172− return $ BehaviorHold h
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
183− Nothing -> return ()
184− Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)
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)
190−data BehaviorSubscribed a
191− = BehaviorSubscribedHold (Hold a)
192− | BehaviorSubscribedPull (PullSubscribed a)
194−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
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
204−--type role Pull representational
206− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
207− , pullCompute :: !(BehaviorM a)
211− = forall a. InvalidatorPull (Pull a)
212− | forall a. InvalidatorSwitch (SwitchSubscribed a)
214−data RootSubscribed a
215− = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
216− , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence
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 ()))
225−data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
227−-- EventM can do everything BehaviorM can, plus create holds
228−newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
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)
237− , pushSubscribedNodeId :: Int
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?
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))
255− , mergeSubscribedNodeId :: Int
259−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
261− = Merge { mergeParents :: !(DMap (WrapArg Event k))
262− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
265−data FanSubscriberKey k a where
266− FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]
268−instance GEq k => GEq (FanSubscriberKey k) where
269− geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of
271− Just Refl -> Just Refl
273−instance GCompare k => GCompare (FanSubscriberKey k) where
274− gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of
280− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))
281− , fanSubscribedParent :: !(EventSubscribed (DMap k))
282− , fanSubscribedSelf :: !(Subscriber (DMap k))
284− , fanSubscribedNodeId :: Int
289− = Fan { fanParent :: !(Event (DMap k))
290− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
293−data SwitchSubscribed a
294− = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
295− , switchSubscribedHeight :: !(IORef Int)
296− , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
297− , switchSubscribedSelf :: !(Subscriber a)
298− , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
299− , switchSubscribedOwnInvalidator :: !Invalidator
300− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
301− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
302− , switchSubscribedParent :: !(Behavior (Event a))
303− , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))
305− , switchSubscribedNodeId :: Int
310− = Switch { switchParent :: !(Behavior (Event a))
311− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
314−data CoincidenceSubscribed a
315− = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
316− , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
317− , coincidenceSubscribedHeight :: !(IORef Int)
318− , coincidenceSubscribedOuter :: !(Subscriber (Event a))
319− , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
320− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
322− , coincidenceSubscribedNodeId :: Int
327− = Coincidence { coincidenceParent :: !(Event (Event a))
328− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
331−data Box a = Box { unBox :: a }
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))
338−showWeakSubscriberType :: WeakSubscriber a -> String
339−showWeakSubscriberType = \case
340− WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"
341− WeakSubscriberSimple _ -> "WeakSubscriberSimple"
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
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)
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"
368− = EventRoot !(Root a)
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)
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"
386−data EventSubscribed a
387− = EventSubscribedRoot !(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)
395−--type role Behavior representational
397− = BehaviorHold !(Hold a)
399− | BehaviorPull !(Pull a)
401−-- ResultM can read behaviors and events
402−type ResultM = EventM
404−{-# NOINLINE unsafeNewIORef #-}
405−unsafeNewIORef :: a -> b -> IORef b
406−unsafeNewIORef _ b = unsafePerformIO $ newIORef b
408−instance Functor Event where
409− fmap f = push $ return . Just . f
411−instance Functor Behavior where
412− fmap f = pull . liftM f . readBehaviorTracked
414−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
415−push :: (a -> EventM (Maybe b)) -> Event a -> Event b
416−push f e = EventPush $ Push
419− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
421−{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
423−{-# NOINLINE pull #-}
424−pull :: BehaviorM a -> Behavior a
425−pull a = BehaviorPull $ Pull
427− , pullValue = unsafeNewIORef a Nothing
429−{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}
431−{-# NOINLINE switch #-}
432−switch :: Behavior (Event a) -> Event a
433−switch a = EventSwitch $ Switch
435− , switchSubscribed = unsafeNewIORef a Nothing
437−{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}
439−coincidence :: Event (Event a) -> Event a
440−coincidence a = EventCoincidence $ Coincidence
441− { coincidenceParent = a
442− , coincidenceSubscribed = unsafeNewIORef a Nothing
445−newRoot :: IO (Root a)
447− occRef <- newIORef Nothing
448− subscribedRef <- newIORef Nothing
450− { rootOccurrence = occRef
451− , rootSubscribed = subscribedRef
452− , rootInit = const $ return $ return ()
455−propagateAndUpdateSubscribersRef subscribersRef a = do
456− subscribers <- liftIO $ readIORef subscribersRef
457− liftIO $ writeIORef subscribersRef []
458− stillAlive <- propagate a subscribers
459− liftIO $ modifyIORef' subscribersRef (++stillAlive)
461−-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
462−run :: [DSum RootTrigger] -> ResultM b -> IO b
464− when debugPropagate $ putStrLn "Running an event frame"
465− result <- runFrame $ do
466− forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do
467− liftIO $ writeIORef occRef $ Just a
468− scheduleClear occRef
469− forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do
470− propagateAndUpdateSubscribersRef subscribersRef a
471− delayedRef <- EventM $ asks eventEnvDelayedMerges
473− delayed <- liftIO $ readIORef delayedRef
474− case IntMap.minViewWithKey delayed of
475− Nothing -> return ()
476− Just ((currentHeight, current), future) -> do
477− when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight
478− putCurrentHeight currentHeight
479− liftIO $ writeIORef delayedRef future
480− forM_ current $ \d -> case d of
481− DelayedMerge subscribed -> do
482− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
483− case height `compare` currentHeight of
484− LT -> error "Somehow a merge's height has been decreased after it was scheduled"
485− GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
487− m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
488− liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty
489− --TODO: Assert that m is not empty
490− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m
491− scheduleClear $ mergeSubscribedOccurrence subscribed
492− propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
495− putCurrentHeight maxBound
497− when debugPropagate $ putStrLn "Done running an event frame"
500−data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
502−data SomeAssignment = forall a. SomeAssignment (Hold a) a
504−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
506−debugFinalize :: Bool
507−debugFinalize = False
509−mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
510−mkWeakPtrWithDebug x debugNote = mkWeakPtr x $
512− then Just $ putStrLn $ "finalizing: " ++ debugNote
515−type WeakList a = [Weak a]
517−--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?
518−traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]
519−traverseAndCleanWeakList_ deRef ws f = go ws
520− where go [] = return []
530−-- | Propagate everything at the current height
531−propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
532−propagate a subscribers = do
533− traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
534− SubscriberPush compute subscribed -> do
535− when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
538− Nothing -> return () -- No need to write a Nothing back into the Ref
540− liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
541− scheduleClear $ pushSubscribedOccurrence subscribed
542− liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
543− SubscriberMerge k subscribed -> do
544− when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
545− oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
546− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM
547− when (DMap.null oldM) $ do -- Only schedule the firing once
548− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
549− --TODO: assertions about height
550− currentHeight <- getCurrentHeight
551− when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
552− scheduleMerge height subscribed
553− SubscriberFan subscribed -> do
554− subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
555− when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
556− --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
557− forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of
559− when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
562− _ <- propagate v subsubs --TODO: use the value of this
564− --TODO: The following is way too slow to do all the time
565− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do
566− subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
567− return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))
568− liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
569− SubscriberHold h -> do
570− invalidators <- liftIO $ readIORef $ holdInvalidators h
571− when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
572− toAssignRef <- askToAssignRef
573− liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
574− SubscriberSwitch subscribed -> do
575− when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
576− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
577− scheduleClear $ switchSubscribedOccurrence subscribed
578− subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
579− liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
580− SubscriberCoincidenceOuter subscribed -> do
581− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
582− outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
583− when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
584− (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
585− when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ)
586− when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight
587− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
588− scheduleClear $ coincidenceSubscribedInnerParent subscribed
591− when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
592− writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
593− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
594− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
595− Just o -> do -- Since it's already firing, no need to adjust height
596− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
597− scheduleClear $ coincidenceSubscribedOccurrence subscribed
598− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
599− SubscriberCoincidenceInner subscribed -> do
600− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
601− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
602− scheduleClear $ coincidenceSubscribedOccurrence subscribed
603− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
605−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
607−subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
608−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
609− let !subInner = SubscriberCoincidenceInner subscribedUnsafe
610− wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
611− innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
612− innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
613− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
614− let height = max innerHeight outerHeight
615− emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing
616− return (innerOcc, height, innerSubd)
618−readBehavior :: Behavior a -> IO a
619−readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
621−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a
622−runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi
624−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
625−askInvalidator = liftM (fmap fst) $ BehaviorM ask
627−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
628−askParentsRef = liftM (fmap snd) $ BehaviorM ask
630−readBehaviorTracked :: Behavior a -> BehaviorM a
631−readBehaviorTracked b = case b of
632− BehaviorHold h -> do
633− result <- liftIO $ readIORef $ holdValue h
634− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
635− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
636− liftIO $ touch $ holdSubscriber h
638− BehaviorConst a -> return a
639− BehaviorPull p -> do
640− val <- liftIO $ readIORef $ pullValue p
642− Just subscribed -> do
643− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
644− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
645− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
646− return $ pullSubscribedValue subscribed
648− let !i = InvalidatorPull p
649− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
650− parentsRef <- liftIO $ newIORef []
651− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
652− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
653− parents <- liftIO $ readIORef parentsRef
654− let subscribed = PullSubscribed
655− { pullSubscribedValue = a
656− , pullSubscribedInvalidators = invsRef
657− , pullSubscribedOwnInvalidator = i
658− , pullSubscribedParents = parents
660− liftIO $ writeIORef (pullValue p) $ Just subscribed
661− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
664−readEvent :: Event a -> ResultM (Maybe a)
665−readEvent e = case e of
666− EventRoot r -> liftIO $ readIORef $ rootOccurrence r
667− EventNever -> return Nothing
669− subscribed <- getPushSubscribed p
671− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
672− touch $ pushSubscribedSelf subscribed
675− subscribed <- getMergeSubscribed m
677− result <- readIORef $ mergeSubscribedOccurrence subscribed
678− touch $ mergeSubscribedSelf subscribed
681− parentOcc <- readEvent $ fanParent f
682− return $ DMap.lookup k =<< parentOcc
684− subscribed <- getSwitchSubscribed s
686− result <- readIORef $ switchSubscribedOccurrence subscribed
687− touch $ switchSubscribedSelf subscribed
688− touch $ switchSubscribedOwnInvalidator subscribed
690− EventCoincidence c -> do
691− subscribed <- getCoincidenceSubscribed c
693− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
694− touch $ coincidenceSubscribedOuter subscribed
695− --TODO: do we need to touch the inner subscriber?
698−-- Always refers to 0
699−{-# NOINLINE zeroRef #-}
701−zeroRef = unsafePerformIO $ newIORef 0
703−getEventSubscribed :: Event a -> EventM (EventSubscribed a)
704−getEventSubscribed e = case e of
705− EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r
706− EventNever -> return EventSubscribedNever
707− EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
708− EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
709− EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m
710− EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s
711− EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c
713−debugSubscribe :: Bool
714−debugSubscribe = False
716−subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()
717−subscribeEventSubscribed es ws = case es of
718− EventSubscribedRoot r -> do
719− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"
720− modifyIORef' (rootSubscribedSubscribers r) (ws:)
721− EventSubscribedNever -> do
722− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"
724− EventSubscribedPush subscribed -> do
725− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"
726− modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
727− EventSubscribedFan k subscribed -> do
728− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
729− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]
730− EventSubscribedMerge subscribed -> do
731− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
732− modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
733− EventSubscribedSwitch subscribed -> do
734− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"
735− modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)
736− EventSubscribedCoincidence subscribed -> do
737− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"
738− modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)
740−getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
741−getEventSubscribedOcc es = case es of
742− EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r
743− EventSubscribedNever -> return Nothing
744− EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
745− EventSubscribedFan k subscribed -> do
746− parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
747− let occ = DMap.lookup k =<< parentOcc
749− EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
750− EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
751− EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed
753−eventSubscribedHeightRef :: EventSubscribed a -> IORef Int
754−eventSubscribedHeightRef es = case es of
755− EventSubscribedRoot _ -> zeroRef
756− EventSubscribedNever -> zeroRef
757− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
758− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed
759− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
760− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
761− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
763−subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)
765− subd <- getEventSubscribed e
766− liftIO $ subscribeEventSubscribed subd ws
769−getRootSubscribed :: Root a -> EventM (RootSubscribed a)
770−getRootSubscribed r = do
771− mSubscribed <- liftIO $ readIORef $ rootSubscribed r
773− Just subscribed -> return subscribed
774− Nothing -> liftIO $ do
775− subscribersRef <- newIORef []
776− let !subscribed = RootSubscribed
777− { rootSubscribedOccurrence = rootOccurrence r
778− , rootSubscribedSubscribers = subscribersRef
780− -- 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
781− uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
782− addFinalizer subscribed $ do
783−-- putStrLn "Uninit root"
785− liftIO $ writeIORef (rootSubscribed r) $ Just subscribed
788−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
789−getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)
790−getPushSubscribed p = do
791− mSubscribed <- liftIO $ readIORef $ pushSubscribed p
793− Just subscribed -> return subscribed
794− Nothing -> do -- Not yet subscribed
795− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
796− let !s = SubscriberPush (pushCompute p) subscribedUnsafe
797− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
798− subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
799− parentOcc <- liftIO $ getEventSubscribedOcc subd
800− occ <- liftM join $ mapM (pushCompute p) parentOcc
801− occRef <- liftIO $ newIORef occ
802− when (isJust occ) $ scheduleClear occRef
803− subscribersRef <- liftIO $ newIORef []
804− let subscribed = PushSubscribed
805− { pushSubscribedOccurrence = occRef
806− , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
807− , pushSubscribedSubscribers = subscribersRef
808− , pushSubscribedSelf = unsafeCoerce s
809− , pushSubscribedParent = subd
811− , pushSubscribedNodeId = unsafeNodeId p
814− liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
817−getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)
818−getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
819− mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
821− Just subscribed -> return subscribed
822− Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
823− subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
824− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
825− let !s = Box subscribedUnsafe
826− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
827− 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
828− parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
829− parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
830− height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
831− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)
832− let dm = DMap.fromDistinctAscList $ catMaybes $ map (^._2) subscribers
833− subscriberHeights = map (^._3) subscribers
835− if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
837− else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here
838− currentHeight <- getCurrentHeight
839− let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
840− then (if DMap.null dm then Nothing else Just dm, DMap.empty)
842− when (not $ DMap.null accum) $ do
843− scheduleMerge myHeight subscribedUnsafe
844− occRef <- liftIO $ newIORef occ
845− when (isJust occ) $ scheduleClear occRef
846− accumRef <- liftIO $ newIORef accum
847− heightRef <- liftIO $ newIORef myHeight
848− subsRef <- liftIO $ newIORef []
849− let subscribed = MergeSubscribed
850− { mergeSubscribedOccurrence = occRef
851− , mergeSubscribedAccum = accumRef
852− , mergeSubscribedHeight = heightRef
853− , mergeSubscribedSubscribers = subsRef
854− , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?
855− , mergeSubscribedParents = DMap.fromDistinctAscList $ map (^._4) subscribers
857− , mergeSubscribedNodeId = unsafeNodeId m
860− liftIO $ writeIORef subscribedRef subscribed
862− where emptyMergeSubscribed = do --TODO: This should never happen
863− occRef <- liftIO $ newIORef Nothing
864− accumRef <- liftIO $ newIORef DMap.empty
865− subsRef <- liftIO $ newIORef []
866− return $ MergeSubscribed
867− { mergeSubscribedOccurrence = occRef
868− , mergeSubscribedAccum = accumRef
869− , mergeSubscribedHeight = zeroRef
870− , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak
871− , mergeSubscribedSelf = unsafeCoerce ()
872− , mergeSubscribedParents = DMap.empty
874− , mergeSubscribedNodeId = -1
878−getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)
879−getFanSubscribed f = do
880− mSubscribed <- liftIO $ readIORef $ fanSubscribed f
882− Just subscribed -> return subscribed
884− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
885− let !sub = SubscriberFan subscribedUnsafe
886− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
887− subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
888− subscribersRef <- liftIO $ newIORef DMap.empty
889− let subscribed = FanSubscribed
890− { fanSubscribedParent = subd
891− , fanSubscribedSubscribers = subscribersRef
892− , fanSubscribedSelf = sub
894− , fanSubscribedNodeId = unsafeNodeId f
897− liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
900−getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)
901−getSwitchSubscribed s = do
902− mSubscribed <- liftIO $ readIORef $ switchSubscribed s
904− Just subscribed -> return subscribed
906− subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
907− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
908− let !i = InvalidatorSwitch subscribedUnsafe
909− !sub = SubscriberSwitch subscribedUnsafe
910− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
911− wiRef <- liftIO $ newIORef wi
912− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
913− selfWeakRef <- liftIO $ newIORef wsub
914− parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
915− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)
916− subd <- subscribe e $ WeakSubscriberSimple wsub
917− subdRef <- liftIO $ newIORef subd
918− parentOcc <- liftIO $ getEventSubscribedOcc subd
919− occRef <- liftIO $ newIORef parentOcc
920− when (isJust parentOcc) $ scheduleClear occRef
921− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
922− subscribersRef <- liftIO $ newIORef []
923− let subscribed = SwitchSubscribed
924− { switchSubscribedOccurrence = occRef
925− , switchSubscribedHeight = heightRef
926− , switchSubscribedSubscribers = subscribersRef
927− , switchSubscribedSelf = sub
928− , switchSubscribedSelfWeak = selfWeakRef
929− , switchSubscribedOwnInvalidator = i
930− , switchSubscribedOwnWeakInvalidator = wiRef
931− , switchSubscribedBehaviorParents = parentsRef
932− , switchSubscribedParent = switchParent s
933− , switchSubscribedCurrentParent = subdRef
935− , switchSubscribedNodeId = unsafeNodeId s
938− liftIO $ writeIORef subscribedRef subscribed
939− liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
942−getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)
943−getCoincidenceSubscribed c = do
944− mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
946− Just subscribed -> return subscribed
948− subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
949− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
950− let !subOuter = SubscriberCoincidenceOuter subscribedUnsafe
951− wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
952− outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
953− outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
954− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
955− (occ, height, mInnerSubd) <- case outerOcc of
956− Nothing -> return (Nothing, outerHeight, Nothing)
958− (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
959− return (occ, height, Just innerSubd)
960− occRef <- liftIO $ newIORef occ
961− when (isJust occ) $ scheduleClear occRef
962− heightRef <- liftIO $ newIORef height
963− innerSubdRef <- liftIO $ newIORef mInnerSubd
964− scheduleClear innerSubdRef
965− subscribersRef <- liftIO $ newIORef []
966− let subscribed = CoincidenceSubscribed
967− { coincidenceSubscribedOccurrence = occRef
968− , coincidenceSubscribedHeight = heightRef
969− , coincidenceSubscribedSubscribers = subscribersRef
970− , coincidenceSubscribedOuter = subOuter
971− , coincidenceSubscribedOuterParent = outerSubd
972− , coincidenceSubscribedInnerParent = innerSubdRef
974− , coincidenceSubscribedNodeId = unsafeNodeId c
977− liftIO $ writeIORef subscribedRef subscribed
978− liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
981−merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
982−merge m = EventMerge $ Merge
984− , mergeSubscribed = unsafeNewIORef m Nothing
987−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
989−fan :: GCompare k => Event (DMap k) -> EventSelector k
993− , fanSubscribed = unsafeNewIORef e Nothing
995− in EventSelector $ \k -> EventFan k f
997−-- | Run an event action outside of a frame
998−runFrame :: EventM a -> IO a
1000− toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1001− holdInitRef <- newIORef []
1002− heightRef <- newIORef 0
1003− toClearRef <- newIORef []
1004− coincidenceInfosRef <- newIORef []
1005− delayedRef <- liftIO $ newIORef IntMap.empty
1006− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do
1008− let runHoldInits = do
1009− holdInits <- liftIO $ readIORef holdInitRef
1010− if null holdInits then return () else do
1011− liftIO $ writeIORef holdInitRef []
1012− forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h
1014− runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1016− toClear <- readIORef toClearRef
1017− forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1018− toAssign <- readIORef toAssignRef
1019− toReconnectRef <- newIORef []
1020− forM_ toAssign $ \(SomeAssignment h v) -> do
1021− writeIORef (holdValue h) v
1022− writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)
1023− coincidenceInfos <- readIORef coincidenceInfosRef
1024− forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do
1027− mapM_ invalidateCoincidenceHeight mcs
1028− toReconnect <- readIORef toReconnectRef
1029− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1030− wsub <- readIORef $ switchSubscribedSelfWeak subscribed
1032− wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1034− let !i = switchSubscribedOwnInvalidator subscribed
1035− wi' <- mkWeakPtrWithDebug i "wi'"
1036− writeIORef (switchSubscribedBehaviorParents subscribed) []
1037− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))
1038− --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1039− let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk
1040− wsub' <- mkWeakPtrWithDebug sub "wsub'"
1041− writeIORef (switchSubscribedSelfWeak subscribed) wsub'
1042− 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
1044− stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1045− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1046− EventRoot _ -> "EventRoot"
1047− EventNever -> "EventNever"
1048− _ -> "something else"
1050− writeIORef (switchSubscribedCurrentParent subscribed) subd'
1051− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1052− myHeight <- readIORef $ switchSubscribedHeight subscribed
1053− if parentHeight == myHeight then return () else do
1054− writeIORef (switchSubscribedHeight subscribed) parentHeight
1055− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1056− forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1057− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1058− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1061−invalidHeight :: Int
1062−invalidHeight = -1000
1064−invalidateSubscriberHeight :: WeakSubscriber a -> IO ()
1065−invalidateSubscriberHeight ws = do
1066− ms <- deRefWeakSubscriber ws
1068− Nothing -> return () --TODO: cleanup?
1069− Just s -> case s of
1070− SubscriberPush _ subscribed -> do
1071− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1072− mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1073− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1074− SubscriberMerge _ subscribed -> do
1075− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1076− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1077− when (oldHeight /= invalidHeight) $ do
1078− writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight
1079− mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1080− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1081− SubscriberFan subscribed -> do
1082− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1083− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1084− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())
1085− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1086− SubscriberHold _ -> return ()
1087− SubscriberSwitch subscribed -> do
1088− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1089− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1090− when (oldHeight /= invalidHeight) $ do
1091− writeIORef (switchSubscribedHeight subscribed) $ invalidHeight
1092− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1093− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1094− SubscriberCoincidenceOuter subscribed -> do
1095− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1096− invalidateCoincidenceHeight subscribed
1097− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1098− SubscriberCoincidenceInner subscribed -> do
1099− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1100− invalidateCoincidenceHeight subscribed
1101− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1103−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1104−invalidateCoincidenceHeight subscribed = do
1105− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1106− when (oldHeight /= invalidHeight) $ do
1107− writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight
1108− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
1110−--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
1112−recalculateSubscriberHeight :: WeakSubscriber a -> IO ()
1113−recalculateSubscriberHeight ws = do
1114− ms <- deRefWeakSubscriber ws
1116− Nothing -> return () --TODO: cleanup?
1117− Just s -> case s of
1118− SubscriberPush _ subscribed -> do
1119− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1120− mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1121− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1122− SubscriberMerge _ subscribed -> do
1123− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1124− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1125− when (oldHeight == invalidHeight) $ do
1126− height <- calculateMergeHeight subscribed
1127− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1128− 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
1129− writeIORef (mergeSubscribedHeight subscribed) height
1130− mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1131− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1132− SubscriberFan subscribed -> do
1133− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1134− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1135− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())
1136− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1137− SubscriberHold _ -> return ()
1138− SubscriberSwitch subscribed -> do
1139− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1140− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1141− when (oldHeight == invalidHeight) $ do
1142− height <- calculateSwitchHeight subscribed
1143− when (height /= invalidHeight) $ do
1144− writeIORef (switchSubscribedHeight subscribed) height
1145− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1146− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1147− SubscriberCoincidenceOuter subscribed -> do
1148− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1149− void $ recalculateCoincidenceHeight subscribed
1150− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1151− SubscriberCoincidenceInner subscribed -> do
1152− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1153− void $ recalculateCoincidenceHeight subscribed
1154− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1156−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1157−recalculateCoincidenceHeight subscribed = do
1158− oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1159− when (oldHeight == invalidHeight) $ do
1160− height <- calculateCoincidenceHeight subscribed
1161− when (height /= invalidHeight) $ do
1162− writeIORef (coincidenceSubscribedHeight subscribed) height
1163− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones
1165−calculateMergeHeight :: MergeSubscribed k -> IO Int
1166−calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1167− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do
1168− readIORef $ eventSubscribedHeightRef es
1169− return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
1171−calculateSwitchHeight :: SwitchSubscribed a -> IO Int
1172−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)
1174−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int
1175−calculateCoincidenceHeight subscribed = do
1176− outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed
1177− innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1178− return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1181−recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int
1182−recalculateEventSubscribedHeight es = case es of
1183− EventSubscribedRoot _ -> return 0
1184− EventSubscribedNever -> return 0
1185− EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed
1186− EventSubscribedMerge subscribed -> do
1187− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1188− if oldHeight /= invalidHeight then return oldHeight else do
1189− height <- calculateMergeHeight subscribed
1190− writeIORef (mergeSubscribedHeight subscribed) height
1192− EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed
1193− EventSubscribedSwitch subscribed -> do
1194− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1195− if oldHeight /= invalidHeight then return oldHeight else do
1196− height <- calculateSwitchHeight subscribed
1197− writeIORef (switchSubscribedHeight subscribed) height
1199− EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed
1202−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)
1204−debugInvalidate :: Bool
1205−debugInvalidate = False
1207−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1208−invalidate toReconnectRef wis = do
1209− forM_ wis $ \wi -> do
1213− when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"
1214− return () --TODO: Should we clean this up here?
1216− finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1218− InvalidatorPull p -> do
1219− when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"
1220− mVal <- readIORef $ pullValue p
1221− forM_ mVal $ \val -> do
1222− writeIORef (pullValue p) Nothing
1223− writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1224− InvalidatorSwitch subscribed -> do
1225− when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"
1226− modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1227− 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
1229−--------------------------------------------------------------------------------
1230−-- Reflex integration
1231−--------------------------------------------------------------------------------
1235−instance R.Reflex Spider where
1236− newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1237− newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }
1238− type PullM Spider = BehaviorM
1239− type PushM Spider = EventM
1240− {-# INLINE never #-}
1241− {-# INLINE constant #-}
1242− never = SpiderEvent EventNever
1243− constant = SpiderBehavior . BehaviorConst
1244− push f = SpiderEvent. push f . unSpiderEvent
1245− pull = SpiderBehavior . pull
1246− merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))
1247− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1248− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
1249− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
1251−instance R.MonadSample Spider SpiderHost where
1252− {-# INLINE sample #-}
1253− sample = SpiderHost . readBehavior . unSpiderBehavior
1255−instance R.MonadHold Spider SpiderHost where
1256− hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent
1258−instance R.MonadSample Spider BehaviorM where
1259− {-# INLINE sample #-}
1260− sample = readBehaviorTracked . unSpiderBehavior
1262−instance R.MonadSample Spider EventM where
1263− {-# INLINE sample #-}
1264− sample = liftIO . readBehavior . unSpiderBehavior
1266−instance R.MonadHold Spider EventM where
1267− {-# INLINE hold #-}
1268− hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
1270−newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))
1272−instance R.ReflexHost Spider where
1273− type EventTrigger Spider = RootTrigger
1274− type EventHandle Spider = R.Event Spider
1275− type HostFrame Spider = SpiderHostFrame
1277−instance R.MonadReadEvent Spider ResultM where
1278− {-# INLINE readEvent #-}
1279− readEvent = liftM (fmap return) . readEvent . unSpiderEvent
1281−--TODO: Can probably get rid of this now that we're not using it for performEvent
1282−instance MonadTypedId EventM where
1283− type TypedId EventM = TypedId IO
1284− {-# INLINE getTypedId #-}
1288−instance MonadRef EventM where
1289− type Ref EventM = Ref IO
1290− {-# INLINE newRef #-}
1291− {-# INLINE readRef #-}
1292− {-# INLINE writeRef #-}
1293− {-# INLINE atomicModifyRef #-}
1294− newRef = liftIO . newRef
1295− readRef = liftIO . readRef
1296− writeRef r a = liftIO $ writeRef r a
1297− atomicModifyRef r f = liftIO $ atomicModifyRef r f
1299−newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
1301−newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
1303−instance R.MonadSample Spider SpiderHostFrame where
1304− sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can
1306−instance R.MonadHold Spider SpiderHostFrame where
1307− {-# INLINE hold #-}
1308− hold v0 e = SpiderHostFrame $ R.hold v0 e
1310−newEventWithTriggerIO f= do
1311− occRef <- newIORef Nothing
1312− subscribedRef <- newIORef Nothing
1314− { rootOccurrence = occRef
1315− , rootSubscribed = subscribedRef
1318− return $ SpiderEvent $ EventRoot r
1320−instance R.MonadReflexCreateTrigger Spider SpiderHost where
1321− newEventWithTrigger = SpiderHost . newEventWithTriggerIO
1323−instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
1324− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO
1326−instance R.MonadReflexHost Spider SpiderHost where
1327− fireEventsAndRead es a = SpiderHost $ run es a
1328− subscribeEvent e = SpiderHost $ do
1329− _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1331− runFrame = SpiderHost . runFrame
1332− runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
1334−instance MonadRef SpiderHost where
1335− type Ref SpiderHost = Ref IO
1336− newRef = SpiderHost . newRef
1337− readRef = SpiderHost . readRef
1338− writeRef r = SpiderHost . writeRef r
1339− atomicModifyRef r = SpiderHost . atomicModifyRef r
1341−instance MonadRef SpiderHostFrame where
1342− type Ref SpiderHostFrame = Ref IO
1343− newRef = SpiderHostFrame . newRef
1344− readRef = SpiderHostFrame . readRef
1345− writeRef r = SpiderHostFrame . writeRef r
1346− atomicModifyRef r = SpiderHostFrame . atomicModifyRef r