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