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