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