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