@@ -2,7 +2,6 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE ConstraintKinds #-}
44{-# LANGUAGE EmptyDataDecls #-}
5−{-# LANGUAGE ExistentialQuantification #-}
65{-# LANGUAGE FlexibleContexts #-}
76{-# LANGUAGE FlexibleInstances #-}
87{-# LANGUAGE FunctionalDependencies #-}
@@ -18,6 +17,10 @@
1817{-# LANGUAGE TypeFamilies #-}
1918{-# LANGUAGE TypeOperators #-}
2019{-# LANGUAGE UndecidableInstances #-}
20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
22+{-# OPTIONS_GHC -fno-warn-orphans #-}
23+#endif
2124-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2225-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2326module Reflex.Spider.Internal where
@@ -31,46 +34,57 @@ import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
3134import Control.Monad.Primitive
3235import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
3336import Control.Monad.Ref
34−import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
3537import Data.Align
3638import Data.Coerce
3739import Data.Dependent.Map (DMap, DSum (..))
3840import qualified Data.Dependent.Map as DMap
3941import Data.Foldable hiding (concat, elem, sequence_)
4042import Data.Function
41−import Data.Functor.Compose
43+import Data.Functor.Constant
44+import Data.Functor.Misc
45+import Data.Functor.Product
4246import Data.GADT.Compare
4347import Data.IntMap.Strict (IntMap)
4448import qualified Data.IntMap.Strict as IntMap
4549import Data.IORef
4650import Data.List hiding (foldl')
47−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
48−import qualified Data.List.NonEmpty as NonEmpty
4951import Data.Maybe
50−import Data.Monoid (mempty, (<>))
52+import Data.Monoid ((<>))
53+import Data.Proxy
5154import Data.Some (Some)
5255import qualified Data.Some as Some
5356import Data.These
5457import Data.Traversable
55−import Data.Tree (Forest, Tree (..), drawForest)
5658import Data.Word
59+import GHC.Exts
5760import GHC.IORef (IORef (..))
5861import GHC.Stack
62+import Reflex.FunctorMaybe
5963import System.IO.Unsafe
6064import System.Mem.Weak
6165import Unsafe.Coerce
6266
67+#ifdef DEBUG_CYCLES
68+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
69+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
70+import qualified Data.List.NonEmpty as NonEmpty
71+import Data.Monoid (mempty)
72+import Data.Tree (Forest, Tree (..), drawForest)
73+#endif
74+
6375import Data.WeakBag (WeakBag, WeakBagTicket)
6476import qualified Data.WeakBag as WeakBag
77+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78+import Data.Type.Coercion
79+import qualified Reflex.Class
6580import qualified Reflex.Class as R
66−import qualified Reflex.Host.Class as R
81+import qualified Reflex.Host.Class
82+#endif
83+import Reflex.Patch
6784
6885-- Note: must come last to silence warnings due to AMP on GHC < 7.10
6986import Prelude hiding (any, concat, mapM, mapM_, sequence)
7087
71−type SubscriberList a = WeakBag (Subscriber a)
72−type SubscriberListTicket a = WeakBagTicket (Subscriber a)
73−
7488debugPropagate :: Bool
7589
7690debugInvalidateHeight :: Bool
@@ -90,35 +104,32 @@ debugInvalidate = True
90104class HasNodeId a where
91105 getNodeId :: a -> Int
92106
93−instance HasNodeId (Hold p a) where
107+instance HasNodeId (Hold x p a) where
94108 getNodeId = holdNodeId
95109
96−instance HasNodeId (PushSubscribed a b) where
110+instance HasNodeId (PushSubscribed x a b) where
97111 getNodeId = pushSubscribedNodeId
98112
99−instance HasNodeId (SwitchSubscribed a) where
113+instance HasNodeId (SwitchSubscribed x a) where
100114 getNodeId = switchSubscribedNodeId
101115
102−instance HasNodeId (MergeSubscribed a) where
103− getNodeId = mergeSubscribedNodeId
104−
105−instance HasNodeId (FanSubscribed a) where
116+instance HasNodeId (FanSubscribed x a) where
106117 getNodeId = fanSubscribedNodeId
107118
108−instance HasNodeId (CoincidenceSubscribed a) where
119+instance HasNodeId (CoincidenceSubscribed x a) where
109120 getNodeId = coincidenceSubscribedNodeId
110121
111−instance HasNodeId (RootSubscribed a) where
122+instance HasNodeId (RootSubscribed x a) where
112123 getNodeId = rootSubscribedNodeId
113124
114−instance HasNodeId (Pull a) where
125+instance HasNodeId (Pull x a) where
115126 getNodeId = pullNodeId
116127
117128{-# INLINE showNodeId #-}
118129showNodeId :: HasNodeId a => a -> String
119130showNodeId = ("#"<>) . show . getNodeId
120131
121−showSubscriberType :: Subscriber a -> String
132+showSubscriberType :: Subscriber x a -> String
122133showSubscriberType = \case
123134 SubscriberPush _ _ -> "SubscriberPush"
124135 SubscriberMerge _ _ -> "SubscriberMerge"
@@ -131,7 +142,7 @@ showSubscriberType = \case
131142 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
132143 SubscriberHandle -> "SubscriberHandle"
133144
134−showEventType :: Event a -> String
145+showEventType :: Event x a -> String
135146showEventType = \case
136147 EventRoot _ _ -> "EventRoot"
137148 EventNever -> "EventNever"
@@ -179,153 +190,359 @@ unsafeNodeId a = unsafePerformIO $ do
179190-- Event
180191--------------------------------------------------------------------------------
181192
182−data Event a
183− = forall k. GCompare k => EventRoot !(k a) !(Root k)
184− | EventNever
185− | forall b. EventPush !(Push b a)
186− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
187− | forall k. GCompare k => EventFan !(k a) !(Fan k)
188− | EventSwitch !(Switch a)
189− | EventCoincidence !(Coincidence a)
190− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
191− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
192− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
193− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
194−
195−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
196−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
197−subscribe e sub = case e of
198− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
199− EventNever -> return $ EventSubscription Nothing EventSubscribedNever
200− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
201− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
202− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
203− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
204− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
205− EventHold h -> subscribeHoldEvent h sub
206− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
207− EventHoldIdentity h -> subscribeHoldEvent h sub
208− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
209− where
210− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
211− wrap tag getSpecificSubscribed = do
212− (sln, subd) <- getSpecificSubscribed sub
213− return $ EventSubscription (Just sln) $ tag subd
193+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
194+
195+{-# INLINE subscribeAndRead #-}
196+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
197+subscribeAndRead = unEvent
198+
199+{-# RULES
200+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
201+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
202+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
203+ #-}
204+{- RULES
205+ "subscribeAndRead/cacheEvent" forall e. subscribeAndRead (cacheEvent e) = subscribeAndRead e
206+ #-}
207+
208+-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
209+-- caching; if the computation function is very cheap, this is (much) more
210+-- efficient than 'push'
211+{- INLINE [1] pushCheap #-}
212+{-# NOINLINE pushCheap #-}
213+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
214+pushCheap f e = Event $ \sub -> do
215+ (subscription, occ) <- subscribeAndRead e $ sub
216+ { subscriberPropagate = \a -> do
217+ mb <- runComputeM $ f a
218+ mapM_ (subscriberPropagate sub) mb
219+ }
220+ occ' <- join <$> mapM (runComputeM . f) occ
221+ return (subscription, occ')
222+
223+data CacheSubscribed x a
224+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))
225+ , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))
226+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
227+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
228+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
229+ }
230+
231+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
232+-- repeatedly
233+--
234+--TODO: Try a caching strategy where we subscribe directly to the parent when
235+--there's only one subscriber, and then build our own WeakBag only when a second
236+--subscriber joins
237+{-# NOINLINE cacheEvent #-}
238+cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
239+cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
240+ let !mSubscribedRef = unsafeNewIORef e Nothing
241+ mSubscribed <- liftIO $ readIORef mSubscribedRef
242+ case mSubscribed of
243+ Just subscribed -> liftIO $ do
244+ ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
245+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
246+ let es = EventSubscribed
247+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
248+ , eventSubscribedRetained = toAny subscribed
249+ }
250+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
251+ Nothing -> do
252+ weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
253+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
254+ occRef <- liftIO $ newIORef undefined
255+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
256+ { subscriberPropagate = \a -> do
257+ liftIO $ writeIORef occRef $ Just a
258+ scheduleClear occRef
259+ propagate a subscribers
260+ , subscriberInvalidateHeight = \old -> do
261+ WeakBag.traverse subscribers $ invalidateSubscriberHeight old
262+ , subscriberRecalculateHeight = \new -> do
263+ WeakBag.traverse subscribers $ recalculateSubscriberHeight new
264+ }
265+ liftIO $ writeIORef occRef occ
266+ when (isJust occ) $ scheduleClear occRef
267+ let !subscribed = CacheSubscribed
268+ { _cacheSubscribed_subscribers = subscribers
269+ , _cacheSubscribed_weakSelf = weakSelf
270+ , _cacheSubscribed_parent = parentSub
271+ , _cacheSubscribed_cached = mSubscribedRef
272+ , _cacheSubscribed_occurrence = occRef
273+ }
274+ liftIO $ writeIORef mSubscribedRef $ Just subscribed
275+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
276+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)
277+
278+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
279+cleanupCacheSubscribed self = do
280+ unsubscribe $ _cacheSubscribed_parent self
281+ writeIORef (_cacheSubscribed_cached self) Nothing
282+
283+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
284+subscribe e s = fst <$> subscribeAndRead e s
285+
286+{-# INLINE wrap #-}
287+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
288+wrap tag getSpecificSubscribed sub = do
289+ (sln, subd, occ) <- getSpecificSubscribed sub
290+ let es = tag subd
291+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
292+
293+eventRoot :: GCompare k => k a -> Root x k -> Event x a
294+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
295+
296+eventNever :: Event x a
297+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
298+
299+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
300+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
301+
302+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
303+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
304+
305+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
306+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
307+
308+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
309+eventHold !h = Event $ subscribeHoldEvent h
310+
311+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
312+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
214313
215314{-# INLINE subscribeCoincidenceInner #-}
216−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
315+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)
217316subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
218317 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
219− subscription@(EventSubscription _ innerSubd) <- subscribe inner subInner
220− innerOcc <- liftIO $ readEventSubscribed innerSubd
318+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
221319 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
222320 let height = max innerHeight outerHeight
223321 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
224322 return (innerOcc, height, innerSubd)
225323
324+--------------------------------------------------------------------------------
325+-- Subscriber
326+--------------------------------------------------------------------------------
327+
328+data Subscriber x a = Subscriber
329+ { subscriberPropagate :: !(a -> EventM x ())
330+ , subscriberInvalidateHeight :: !(Height -> IO ())
331+ , subscriberRecalculateHeight :: !(Height -> IO ())
332+ }
333+
334+--TODO: Move this comment to WeakBag
335+-- These function are constructor functions that are marked NOINLINE so they are
336+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
337+-- so any weak references that are attached to the constructors will have their
338+-- finalizer run. Using the opaque constructor, does not see the
339+-- constructor application, so it behaves like an IORef and cannot be fused away.
340+--
341+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
342+-- the weak pointer to it in some cases.
343+
344+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
345+newSubscriberHold h = return $ Subscriber
346+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
347+ , subscriberInvalidateHeight = \_ -> return ()
348+ , subscriberRecalculateHeight = \_ -> return ()
349+ }
350+
351+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
352+newSubscriberFan subscribed = return $ Subscriber
353+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
354+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
355+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
356+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
357+ scheduleClear $ fanSubscribedOccurrence subscribed
358+ let f _ (Pair (Identity v) subsubs) = do
359+ propagate v $ _fanSubscribedChildren_list subsubs
360+ return $ Constant ()
361+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
362+ return ()
363+ , subscriberInvalidateHeight = \old -> do
364+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
365+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
366+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
367+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
368+ , subscriberRecalculateHeight = \new -> do
369+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
370+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
371+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
372+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
373+ }
374+
375+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
376+newSubscriberSwitch subscribed = return $ Subscriber
377+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
378+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
379+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
380+ scheduleClear $ switchSubscribedOccurrence subscribed
381+ propagate a $ switchSubscribedSubscribers subscribed
382+ , subscriberInvalidateHeight = \_ -> do
383+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
384+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
385+ when (oldHeight /= invalidHeight) $ do
386+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
387+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
388+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
389+ , subscriberRecalculateHeight = \new -> do
390+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
391+ updateSwitchHeight new subscribed
392+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
393+ }
394+
395+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
396+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
397+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
398+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
399+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
400+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
401+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
402+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
403+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
404+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
405+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
406+ case occ of
407+ Nothing -> do
408+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
409+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
410+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
411+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
412+ Just o -> do -- Since it's already firing, no need to adjust height
413+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
414+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
415+ propagate o $ coincidenceSubscribedSubscribers subscribed
416+ , subscriberInvalidateHeight = \_ -> do
417+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
418+ invalidateCoincidenceHeight subscribed
419+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
420+ , subscriberRecalculateHeight = \_ -> do
421+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
422+ recalculateCoincidenceHeight subscribed
423+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
424+ }
425+
426+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
427+newSubscriberCoincidenceInner subscribed = return $ Subscriber
428+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
429+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
430+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
431+ case occ of
432+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
433+ Nothing -> do
434+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
435+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
436+ propagate a $ coincidenceSubscribedSubscribers subscribed
437+ , subscriberInvalidateHeight = \_ -> do
438+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
439+ invalidateCoincidenceHeight subscribed
440+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
441+ , subscriberRecalculateHeight = \_ -> do
442+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
443+ recalculateCoincidenceHeight subscribed
444+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
445+ }
446+
447+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
448+invalidateSubscriberHeight = flip subscriberInvalidateHeight
449+
450+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
451+recalculateSubscriberHeight = flip subscriberRecalculateHeight
452+
453+-- | Propagate everything at the current height
454+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
455+propagate a subscribers = withIncreasedDepth $ do
456+ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
457+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
458+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
459+
226460--------------------------------------------------------------------------------
227461-- EventSubscribed
228462--------------------------------------------------------------------------------
229463
230−data EventSubscribed a
231− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
232− | EventSubscribedNever
233− | forall b. EventSubscribedPush !(PushSubscribed b a)
234− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
235− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
236− | EventSubscribedSwitch !(SwitchSubscribed a)
237− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
238−
239−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
240−readEventSubscribed = \case
241− EventSubscribedRoot rs -> readRootSubscribed rs
242− EventSubscribedNever -> return Nothing
243− EventSubscribedPush ps -> readPushSubscribed ps
244− EventSubscribedMerge ms -> readMergeSubscribed ms
245− EventSubscribedFan k fs -> readFanSubscribed k fs
246− EventSubscribedSwitch ss -> readSwitchSubscribed ss
247− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
248−
249−{-# INLINE subscribeEventSubscribed #-}
250−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
251−subscribeEventSubscribed es sub = case es of
252− EventSubscribedRoot r -> do
253− traceSubscribe $ "subscribeEventSubscribed Root"
254− Just <$> subscribeRootSubscribed r sub
255− EventSubscribedNever -> do
256− traceSubscribe $ "subscribeEventSubscribed Never"
257− return Nothing
258− EventSubscribedPush subscribed -> do
259− traceSubscribe $ "subscribeEventSubscribed Push"
260− Just <$> subscribePushSubscribed subscribed sub
261− EventSubscribedFan k subscribed -> do
262− traceSubscribe $ "subscribeEventSubscribed Fan"
263− Just <$> subscribeFanSubscribed k subscribed sub
264− EventSubscribedMerge subscribed -> do
265− traceSubscribe $ "subscribeEventSubscribed Merge"
266− Just <$> subscribeMergeSubscribed subscribed sub
267− EventSubscribedSwitch subscribed -> do
268− traceSubscribe $ "subscribeEventSubscribed Switch"
269− Just <$> subscribeSwitchSubscribed subscribed sub
270− EventSubscribedCoincidence subscribed -> do
271− traceSubscribe $ "subscribeEventSubscribed Coincidence"
272− Just <$> subscribeCoincidenceSubscribed subscribed sub
273−
274−{-# INLINE eventSubscribedGetParents #-}
275−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
276−eventSubscribedGetParents = \case
277− EventSubscribedRoot _ -> return []
278− EventSubscribedNever -> return []
279− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
280− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
281− EventSubscribedMerge subscribed -> do
282− ps <- readIORef $ mergeSubscribedParents subscribed
283− return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
284− EventSubscribedSwitch subscribed -> do
285− s <- readIORef $ switchSubscribedCurrentParent subscribed
286− return [Some.This $ _eventSubscription_subscribed s]
287− EventSubscribedCoincidence subscribed -> do
288− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
289− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
290− innerParents = maybeToList $ fmap Some.This innerSubscription
291− return $ outerParent : innerParents
292−
293−getEventSubscribedHeight :: EventSubscribed a -> IO Height
464+toAny :: a -> Any
465+toAny = unsafeCoerce
466+
467+data EventSubscribed x = EventSubscribed
468+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
469+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
470+#ifdef DEBUG_CYCLES
471+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
472+ , eventSubscribedHasOwnHeightRef :: !Bool
473+ , eventSubscribedWhoCreated :: !(IO [String])
474+#endif
475+ }
476+
477+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
478+eventSubscribedRoot !r = EventSubscribed
479+ { eventSubscribedHeightRef = zeroRef
480+ , eventSubscribedRetained = toAny r
481+#ifdef DEBUG_CYCLES
482+ , eventSubscribedGetParents = return []
483+ , eventSubscribedHasOwnHeightRef = False
484+ , eventSubscribedWhoCreated = return ["root"]
485+#endif
486+ }
487+
488+eventSubscribedNever :: EventSubscribed x
489+eventSubscribedNever = EventSubscribed
490+ { eventSubscribedHeightRef = zeroRef
491+ , eventSubscribedRetained = toAny ()
492+#ifdef DEBUG_CYCLES
493+ , eventSubscribedGetParents = return []
494+ , eventSubscribedHasOwnHeightRef = False
495+ , eventSubscribedWhoCreated = return ["never"]
496+#endif
497+ }
498+
499+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
500+eventSubscribedFan !subscribed = EventSubscribed
501+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
502+ , eventSubscribedRetained = toAny subscribed
503+#ifdef DEBUG_CYCLES
504+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
505+ , eventSubscribedHasOwnHeightRef = False
506+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
507+#endif
508+ }
509+
510+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
511+eventSubscribedSwitch !subscribed = EventSubscribed
512+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
513+ , eventSubscribedRetained = toAny subscribed
514+#ifdef DEBUG_CYCLES
515+ , eventSubscribedGetParents = do
516+ s <- readIORef $ switchSubscribedCurrentParent subscribed
517+ return [Some.This $ _eventSubscription_subscribed s]
518+ , eventSubscribedHasOwnHeightRef = True
519+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
520+#endif
521+ }
522+
523+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
524+eventSubscribedCoincidence !subscribed = EventSubscribed
525+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
526+ , eventSubscribedRetained = toAny subscribed
527+#ifdef DEBUG_CYCLES
528+ , eventSubscribedGetParents = do
529+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
530+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
531+ innerParents = maybeToList $ fmap Some.This innerSubscription
532+ return $ outerParent : innerParents
533+ , eventSubscribedHasOwnHeightRef = True
534+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
535+#endif
536+ }
537+
538+getEventSubscribedHeight :: EventSubscribed x -> IO Height
294539getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
295540
296−{-# INLINE eventSubscribedHeightRef #-}
297−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
298−eventSubscribedHeightRef = \case
299− EventSubscribedRoot _ -> zeroRef
300− EventSubscribedNever -> zeroRef
301− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
302− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
303− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
304− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
305− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
306−
307−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
308−whoCreatedEventSubscribed = \case
309− EventSubscribedRoot _ -> return ["root"]
310− EventSubscribedNever -> return ["never"]
311− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
312− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
313− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
314− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
315− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
316−
317−{-# INLINE eventSubscribedHasOwnHeightRef #-}
318−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
319−eventSubscribedHasOwnHeightRef = \case
320− EventSubscribedRoot _ -> False
321− EventSubscribedNever -> False
322− EventSubscribedPush _ -> False
323− EventSubscribedFan _ _ -> False
324− EventSubscribedMerge _ -> True
325− EventSubscribedSwitch _ -> True
326− EventSubscribedCoincidence _ -> True
327−
328−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
541+#ifdef DEBUG_CYCLES
542+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
543+whoCreatedEventSubscribed = eventSubscribedWhoCreated
544+
545+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
329546walkInvalidHeightParents s0 = do
330547 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
331548 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
@@ -335,18 +552,115 @@ walkInvalidHeightParents s0 = do
335552 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
336553 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
337554 return subscribers
555+#endif
556+
557+{-# INLINE subscribeHoldEvent #-}
558+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
559+subscribeHoldEvent = subscribeAndRead . holdEvent
338560
339561--------------------------------------------------------------------------------
340562-- EventSubscription
341563--------------------------------------------------------------------------------
342564
343−data EventSubscription a = EventSubscription
344− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
345− , _eventSubscription_subscribed :: !(EventSubscribed a)
565+data EventSubscription x = EventSubscription
566+ { _eventSubscription_unsubscribe :: !(IO ())
567+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
346568 }
347569
348−unsubscribe :: EventSubscription a -> IO ()
349−unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
570+unsubscribe :: EventSubscription x -> IO ()
571+unsubscribe (EventSubscription u _) = u
572+
573+--------------------------------------------------------------------------------
574+-- Behavior
575+--------------------------------------------------------------------------------
576+
577+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
578+
579+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
580+behaviorHold !h = Behavior $ readHoldTracked h
581+
582+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
583+behaviorHoldIdentity = behaviorHold
584+
585+behaviorConst :: a -> Behavior x a
586+behaviorConst !a = Behavior $ return a
587+
588+behaviorPull :: Pull x a -> Behavior x a
589+behaviorPull !p = Behavior $ do
590+ val <- liftIO $ readIORef $ pullValue p
591+ case val of
592+ Just subscribed -> do
593+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
594+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
595+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
596+ return $ pullSubscribedValue subscribed
597+ Nothing -> do
598+ i <- liftIO $ newInvalidatorPull p
599+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
600+ parentsRef <- liftIO $ newIORef []
601+ holdInits <- askBehaviorHoldInits
602+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
603+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
604+ parents <- liftIO $ readIORef parentsRef
605+ let subscribed = PullSubscribed
606+ { pullSubscribedValue = a
607+ , pullSubscribedInvalidators = invsRef
608+ , pullSubscribedOwnInvalidator = i
609+ , pullSubscribedParents = parents
610+ }
611+ liftIO $ writeIORef (pullValue p) $ Just subscribed
612+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
613+ return a
614+
615+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
616+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
617+
618+{-# INLINE readHoldTracked #-}
619+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
620+readHoldTracked h = do
621+ result <- liftIO $ readIORef $ holdValue h
622+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
623+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
624+ return result
625+
626+{-# INLINABLE readBehaviorUntracked #-}
627+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
628+readBehaviorUntracked b = do
629+ holdInits <- getDeferralQueue
630+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
631+
632+--------------------------------------------------------------------------------
633+-- Dynamic
634+--------------------------------------------------------------------------------
635+
636+data Dynamic x p = Dynamic
637+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
638+ , dynamicUpdated :: !(Event x p)
639+ }
640+
641+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
642+dynamicHold !h = Dynamic
643+ { dynamicCurrent = behaviorHold h
644+ , dynamicUpdated = eventHold h
645+ }
646+
647+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
648+dynamicHoldIdentity = dynamicHold
649+
650+dynamicConst :: PatchTarget p -> Dynamic x p
651+dynamicConst !a = Dynamic
652+ { dynamicCurrent = behaviorConst a
653+ , dynamicUpdated = eventNever
654+ }
655+
656+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
657+dynamicDyn !d = Dynamic
658+ { dynamicCurrent = behaviorDyn d
659+ , dynamicUpdated = eventDyn d
660+ }
661+
662+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
663+dynamicDynIdentity = dynamicDyn
350664
351665--------------------------------------------------------------------------------
352666-- Combinators
@@ -356,31 +670,56 @@ unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
356670--representational so we can use coerce
357671
358672--type role Hold representational
359−data Hold p a
360− = Hold { holdValue :: !(IORef a)
361− , holdInvalidators :: !(IORef [Weak Invalidator])
362− , holdParent :: !(IORef (Either (Event (p a)) (EventSubscription (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
673+data Hold x p
674+ = Hold { holdValue :: !(IORef (PatchTarget p))
675+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
676+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
677+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
363678#ifdef DEBUG_NODEIDS
364679 , holdNodeId :: Int
365680#endif
366681 }
367682
683+data Global
684+
685+{-# NOINLINE globalSpiderTimelineEnv #-}
686+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
687+!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
688+
689+-- | Stores all global data relevant to a particular Spider timeline; only one
690+-- value should exist for each type @x@
691+data SpiderTimelineEnv x = SpiderTimelineEnv
692+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
693+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
694+#ifdef DEBUG
695+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
696+#endif
697+ }
698+type role SpiderTimelineEnv nominal
699+
700+instance GEq SpiderTimelineEnv where
701+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
702+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
703+ else Nothing
704+
368705data EventEnv x
369− = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)
370− , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe
371− , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe
372− , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])
373− , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe
706+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
707+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
708+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
709+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
374710 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
375711 , eventEnvRootClears :: !(IORef [SomeRootClear])
376712 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
377− , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe
378− , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
713+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
714+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
379715 }
380716
381717{-# INLINE runEventM #-}
382−runEventM :: EventM x a -> EventEnv x -> IO a
383−runEventM = runReaderT . unEventM
718+runEventM :: EventM x a -> IO a
719+runEventM = unEventM
720+
721+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
722+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
384723
385724class MonadIO m => Defer a m where
386725 getDeferralQueue :: m (IORef [a])
@@ -391,91 +730,91 @@ defer a = do
391730 q <- getDeferralQueue
392731 liftIO $ modifyIORef' q (a:)
393732
394−instance Defer SomeAssignment (EventM x) where
733+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
395734 {-# INLINE getDeferralQueue #-}
396− getDeferralQueue = EventM $ asks eventEnvAssignments
735+ getDeferralQueue = asksEventEnv eventEnvAssignments
397736
398−instance Defer SomeHoldInit (EventM x) where
737+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
399738 {-# INLINE getDeferralQueue #-}
400− getDeferralQueue = EventM $ asks eventEnvHoldInits
739+ getDeferralQueue = asksEventEnv eventEnvHoldInits
401740
402−instance Defer SomeHoldInit BehaviorM where
741+instance Defer (SomeHoldInit x) (BehaviorM x) where
403742 {-# INLINE getDeferralQueue #-}
404743 getDeferralQueue = BehaviorM $ asks snd
405744
406−instance Defer SomeMergeUpdate (EventM x) where
745+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
407746 {-# INLINE getDeferralQueue #-}
408− getDeferralQueue = EventM $ asks eventEnvMergeUpdates
747+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
409748
410−instance Defer SomeMergeInit (EventM x) where
749+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
411750 {-# INLINE getDeferralQueue #-}
412− getDeferralQueue = EventM $ asks eventEnvMergeInits
751+ getDeferralQueue = asksEventEnv eventEnvMergeInits
413752
414−class HasCurrentHeight m where
753+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
415754 getCurrentHeight :: m Height
416− scheduleMerge :: Height -> MergeSubscribed a -> m ()
755+ scheduleMerge :: Height -> EventM x () -> m ()
417756
418−instance HasCurrentHeight (EventM x) where
757+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
419758 {-# INLINE getCurrentHeight #-}
420− getCurrentHeight = EventM $ do
421− heightRef <- asks eventEnvCurrentHeight
759+ getCurrentHeight = do
760+ heightRef <- asksEventEnv eventEnvCurrentHeight
422761 liftIO $ readIORef heightRef
423762 {-# INLINE scheduleMerge #-}
424− scheduleMerge height subscribed = EventM $ do
425− delayedRef <- asks eventEnvDelayedMerges
426− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]
427−
428−class HasSpiderTimeline x m | m -> x where
429− -- | Retrieve the current SpiderTimeline
430− askSpiderTimeline :: m (SpiderTimeline x)
763+ scheduleMerge height subscribed = do
764+ delayedRef <- asksEventEnv eventEnvDelayedMerges
765+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
431766
432−instance HasSpiderTimeline x (EventM x) where
433− {-# INLINE askSpiderTimeline #-}
434− askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline
767+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
768+class x ~ Global => HasSpiderTimeline x where
769+#else
770+class HasSpiderTimeline x where
771+#endif
772+ -- | Retrieve the current SpiderTimelineEnv
773+ spiderTimeline :: SpiderTimelineEnv x
435774
436−instance HasSpiderTimeline x (SpiderHost x) where
437− {-# INLINE askSpiderTimeline #-}
438− askSpiderTimeline = SpiderHost ask
775+instance HasSpiderTimeline Global where
776+ spiderTimeline = globalSpiderTimelineEnv
439777
440−putCurrentHeight :: Height -> EventM x ()
441−putCurrentHeight h = EventM $ do
442− heightRef <- asks eventEnvCurrentHeight
778+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
779+putCurrentHeight h = do
780+ heightRef <- asksEventEnv eventEnvCurrentHeight
443781 liftIO $ writeIORef heightRef $! h
444782
445−instance Defer SomeClear (EventM x) where
783+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
446784 {-# INLINE getDeferralQueue #-}
447− getDeferralQueue = EventM $ asks eventEnvClears
785+ getDeferralQueue = asksEventEnv eventEnvClears
448786
449787{-# INLINE scheduleClear #-}
450788scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
451789scheduleClear r = defer $ SomeClear r
452790
453−instance Defer SomeRootClear (EventM x) where
791+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
454792 {-# INLINE getDeferralQueue #-}
455− getDeferralQueue = EventM $ asks eventEnvRootClears
793+ getDeferralQueue = asksEventEnv eventEnvRootClears
456794
457795{-# INLINE scheduleRootClear #-}
458796scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
459797scheduleRootClear r = defer $ SomeRootClear r
460798
461−instance Defer SomeResetCoincidence (EventM x) where
799+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
462800 {-# INLINE getDeferralQueue #-}
463− getDeferralQueue = EventM $ asks eventEnvResetCoincidences
801+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
464802
465803-- Note: hold cannot examine its event until after the phase is over
466−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> EventM x (Hold p a) #-}
467−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}
468−hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)
804+{- SPECIALIZE hold :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
805+{-# INLINE [1] hold #-}
806+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
469807hold v0 e = do
470808 valRef <- liftIO $ newIORef v0
471809 invsRef <- liftIO $ newIORef []
472− parentRef <- liftIO $ newIORef $ Left e
810+ parentRef <- liftIO $ newIORef Nothing
473811#ifdef DEBUG_NODEIDS
474812 nodeId <- liftIO newNodeId
475813#endif
476814 let h = Hold
477815 { holdValue = valRef
478816 , holdInvalidators = invsRef
817+ , holdEvent = e
479818 , holdParent = parentRef
480819#ifdef DEBUG_NODEIDS
481820 , holdNodeId = nodeId
@@ -485,37 +824,37 @@ hold v0 e = do
485824 return h
486825
487826{-# INLINE getHoldEventSubscription #-}
488−getHoldEventSubscription :: forall m p a x. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeClear m, R.Patch p, HasCurrentHeight m, Defer SomeMergeInit m, Defer SomeResetCoincidence m, HasSpiderTimeline x m) => Hold p a -> m (EventSubscription (p a))
827+getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)
489828getHoldEventSubscription h = do
490829 ep <- liftIO $ readIORef $ holdParent h
491830 case ep of
492− Right subd -> return subd
493− Left e -> do
831+ Just subd -> return subd
832+ Nothing -> do
833+ let e = holdEvent h
494834 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
495− subscription@(EventSubscription _ subd) <- subscribe e =<< liftIO (newSubscriberHold h)
835+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
496836 liftIO $ writeIORef subscriptionRef $! subscription
497− occ <- liftIO $ readEventSubscribed subd
498837 case occ of
499838 Nothing -> return ()
500839 Just o -> do
501840 old <- liftIO $ readIORef $ holdValue h
502− case R.apply o old of
841+ case apply o old of
503842 Nothing -> return ()
504843 Just new -> do
505844 -- Need to evaluate these so that we don't retain the Hold itself
506845 v <- liftIO $ evaluate $ holdValue h
507846 i <- liftIO $ evaluate $ holdInvalidators h
508847 defer $ SomeAssignment v i new
509− liftIO $ writeIORef (holdParent h) $ Right subscription
848+ liftIO $ writeIORef (holdParent h) $ Just subscription
510849 return subscription
511850
512−type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])
851+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
513852
514853--type role BehaviorM representational
515854-- BehaviorM can sample behaviors
516−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT BehaviorEnv IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
855+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
517856
518−instance Monad BehaviorM where
857+instance Monad (BehaviorM x) where
519858 {-# INLINE (>>=) #-}
520859 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
521860 {-# INLINE (>>) #-}
@@ -525,94 +864,74 @@ instance Monad BehaviorM where
525864 {-# INLINE fail #-}
526865 fail s = BehaviorM $ fail s
527866
528−data BehaviorSubscribed a
529− = forall p. BehaviorSubscribedHold (Hold p a)
530− | BehaviorSubscribedPull (PullSubscribed a)
867+data BehaviorSubscribed x a
868+ = forall p. BehaviorSubscribedHold (Hold x p)
869+ | BehaviorSubscribedPull (PullSubscribed x a)
531870
532−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
871+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
533872
534873--type role PullSubscribed representational
535−data PullSubscribed a
874+data PullSubscribed x a
536875 = PullSubscribed { pullSubscribedValue :: !a
537− , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])
538− , pullSubscribedOwnInvalidator :: !Invalidator
539− , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
876+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
877+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
878+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
540879 }
541880
542881--type role Pull representational
543−data Pull a
544− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
545− , pullCompute :: !(BehaviorM a)
882+data Pull x a
883+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
884+ , pullCompute :: !(BehaviorM x a)
546885#ifdef DEBUG_NODEIDS
547886 , pullNodeId :: Int
548887#endif
549888 }
550889
551−data Invalidator
552− = forall a. InvalidatorPull (Pull a)
553− | forall a. InvalidatorSwitch (SwitchSubscribed a)
890+data Invalidator x
891+ = forall a. InvalidatorPull (Pull x a)
892+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
554893
555−data RootSubscribed a = forall k. GCompare k => RootSubscribed
894+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
556895 { rootSubscribedKey :: !(k a)
557− , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root
558− , rootSubscribedSubscribers :: !(SubscriberList a)
896+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
897+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
559898 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
560899 , rootSubscribedUninit :: IO ()
561− , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
900+ , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
562901#ifdef DEBUG_NODEIDS
563902 , rootSubscribedNodeId :: Int
564903#endif
565904 }
566905
567−data Root (k :: * -> *)
906+data Root x (k :: * -> *)
568907 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
569− , rootSubscribed :: !(IORef (DMap k RootSubscribed))
570− , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
908+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
909+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
571910 }
572911
573−data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)
574−
575−data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)
912+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
576913
577−data SomeMergeInit = forall k. GCompare k => SomeMergeInit !(MergeSubscribed k) !(Event (R.PatchDMap (DMap k Event)))
914+data SomeMergeUpdate x = SomeMergeUpdate
915+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
916+ , _someMergeUpdate_invalidateHeight :: !(IO ())
917+ , _someMergeUpdate_recalculateHeight :: !(IO ())
918+ }
578919
579−data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)
920+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
580921
581922-- EventM can do everything BehaviorM can, plus create holds
582−newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, 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
583−
584−data PushSubscribed a b
585− = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed a b)))
586− , 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)
587− , pushSubscribedHeight :: !(IORef Height)
588− , pushSubscribedSubscribers :: !(SubscriberList b)
589− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now
590− , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed a b)))
591− , pushSubscribedParent :: !(EventSubscription a)
592−#ifdef DEBUG_NODEIDS
593− , pushSubscribedNodeId :: Int
594−#endif
595− }
923+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, 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
596924
597−newtype ComputeM a = ComputeM (ReaderT (IORef [SomeHoldInit]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
925+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
598926
599−instance Defer SomeHoldInit ComputeM where
927+instance Defer (SomeHoldInit x) (ComputeM x) where
600928 getDeferralQueue = ComputeM ask
601929
602−{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}
603−runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a
930+{-# INLINABLE runComputeM #-}
931+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
604932runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
605933
606−data Push a b
607− = Push { pushCompute :: !(a -> ComputeM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)
608− , pushParent :: !(Event a)
609− , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
610− }
611−
612−data MergeSubscribedParent k a = MergeSubscribedParent !(EventSubscription a) !(Subscriber a)
613−
614−mergeSubscribedParentSubscription :: MergeSubscribedParent k a -> EventSubscription a
615−mergeSubscribedParentSubscription (MergeSubscribedParent es _) = es
934+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
616935
617936data HeightBag = HeightBag
618937 { _heightBag_size :: {-# UNPACK #-} !Int
@@ -656,252 +975,108 @@ heightBagVerify b@(HeightBag s c) = if
656975heightBagVerify = id
657976#endif
658977
659−data MergeSubscribed k
660− = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
661− , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
662− , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
663− , mergeSubscribedHeight :: !(IORef Height)
664− , mergeSubscribedHeightBag :: !(IORef HeightBag)
665− , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
666− , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
667− , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
668− , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))
669−#ifdef DEBUG_NODEIDS
670− , mergeSubscribedNodeId :: Int
671−#endif
672− }
673−
674−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
675−data Merge k
676− = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
677− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
678− }
679−
680−data FanSubscribedChildren k a = FanSubscribedChildren
681− { _fanSubscribedChildren_list :: !(SubscriberList a)
682− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed k)
683− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
978+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
979+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
980+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
981+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
684982 }
685983
686−data FanSubscribed k
687− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
688− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
689− , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
984+data FanSubscribed (x :: *) k
985+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
986+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
987+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
988+ , fanSubscribedParent :: !(EventSubscription x)
690989#ifdef DEBUG_NODEIDS
691990 , fanSubscribedNodeId :: Int
692991#endif
693992 }
694993
695−data Fan k
696− = Fan { fanParent :: !(Event (DMap k Identity))
697− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
994+data Fan x k
995+ = Fan { fanParent :: !(Event x (DMap k Identity))
996+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
698997 }
699998
700−data SwitchSubscribed a
701− = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
999+data SwitchSubscribed x a
1000+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
7021001 , switchSubscribedOccurrence :: !(IORef (Maybe a))
7031002 , switchSubscribedHeight :: !(IORef Height)
704− , switchSubscribedSubscribers :: !(SubscriberList a)
705− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
706− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
707− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
708− , switchSubscribedParent :: !(Behavior (Event a))
709− , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
710− , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
1003+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1004+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1005+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1006+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1007+ , switchSubscribedParent :: !(Behavior x (Event x a))
1008+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1009+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
7111010#ifdef DEBUG_NODEIDS
7121011 , switchSubscribedNodeId :: Int
7131012#endif
7141013 }
7151014
716−data Switch a
717− = Switch { switchParent :: !(Behavior (Event a))
718− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
1015+data Switch x a
1016+ = Switch { switchParent :: !(Behavior x (Event x a))
1017+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
7191018 }
7201019
7211020{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
722−data CoincidenceSubscribed a
723− = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
1021+data CoincidenceSubscribed x a
1022+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
7241023 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
725− , coincidenceSubscribedSubscribers :: !(SubscriberList a)
1024+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
7261025 , coincidenceSubscribedHeight :: !(IORef Height)
727− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
728− , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
729− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
730− , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
1026+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1027+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1028+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1029+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
7311030#ifdef DEBUG_NODEIDS
7321031 , coincidenceSubscribedNodeId :: Int
7331032#endif
7341033 }
7351034
736−data Coincidence a
737− = Coincidence { coincidenceParent :: !(Event (Event a))
738− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
1035+data Coincidence x a
1036+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1037+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
7391038 }
7401039
741−data Subscriber a
742− = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?
743− | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
744− | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)
745− | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
746− | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)
747− | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)
748− | SubscriberSwitch (SwitchSubscribed a)
749− | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
750− | SubscriberCoincidenceInner (CoincidenceSubscribed a)
751− | SubscriberHandle
752−
753−-- These function are constructor functions that are marked NOINLINE so they are
754−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
755−-- so any weak references that are attached to the constructors will have their
756−-- finalizer run. Using the opaque constructor, does not see the
757−-- constructor application, so it behaves like an IORef and cannot be fused away.
758−--
759−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
760−-- the weak pointer to it in some cases.
761−
762−--TODO: I think all of these noinlines are now unnecessary
763−{-# NOINLINE newSubscriberPush #-}
764−newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
765−newSubscriberPush compute subd = return $! SubscriberPush compute subd
766−
767−{-# RULES
768− "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
769− #-}
770−{-# NOINLINE newSubscriberHold #-}
771−newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
772−newSubscriberHold h = return $! SubscriberHold h
773−
774−{-# NOINLINE newSubscriberHoldIdentity #-}
775−newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
776−newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
777−
778−{-# NOINLINE newSubscriberMerge #-}
779−newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
780−newSubscriberMerge k subd = return $! SubscriberMerge k subd
781−
782−{-# NOINLINE newSubscriberMergeChange #-}
783−newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
784−newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
785−
786−{-# NOINLINE newSubscriberFan #-}
787−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
788−newSubscriberFan subd = return $! SubscriberFan subd
789−
790−{-# NOINLINE newSubscriberSwitch #-}
791−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
792−newSubscriberSwitch subd = return $! SubscriberSwitch subd
793−
794−{-# NOINLINE newSubscriberCoincidenceOuter #-}
795−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
796−newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
797−
798−{-# NOINLINE newSubscriberCoincidenceInner #-}
799−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
800−newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
801−
8021040{-# NOINLINE newInvalidatorSwitch #-}
803−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
1041+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
8041042newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
8051043
8061044{-# NOINLINE newInvalidatorPull #-}
807−newInvalidatorPull :: Pull a -> IO Invalidator
1045+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
8081046newInvalidatorPull p = return $! InvalidatorPull p
8091047
810−data Dynamic p a
811− = DynamicHold !(Hold p a)
812− | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
813− | DynamicConst !a
814− | DynamicDyn !(Dyn p a)
815− | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
816−
817−{-# INLINE current #-}
818−current :: R.Patch p => Dynamic p a -> Behavior a
819−current = \case
820− DynamicHold h -> BehaviorHold h
821− DynamicHoldIdentity h -> BehaviorHoldIdentity h
822− DynamicConst a -> BehaviorConst a
823− DynamicDyn d -> BehaviorDyn d
824− DynamicDynIdentity d -> BehaviorDynIdentity d
825−
826−--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
827−{-# INLINE updated #-}
828−updated :: R.Patch p => Dynamic p a -> Event (p a)
829−updated = \case
830− DynamicHold h -> EventHold h
831− DynamicHoldIdentity h -> EventHoldIdentity h
832− DynamicConst _ -> EventNever
833− DynamicDyn d -> EventDyn d
834− DynamicDynIdentity d -> EventDynIdentity d
835−
836−newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b
837−newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (Identity . f . runIdentity <$> updated d)
838−
839−instance Functor (Dynamic Identity) where
840− fmap = newMapDyn
841−
842−instance Applicative (Dynamic Identity) where
843− pure = DynamicConst
844− (<*>) = zipDynWith ($)
845− (*>) = zipDynWith (flip const)
846− (<*) = zipDynWith const
847−
848−instance R.FunctorMaybe Event where
1048+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
8491049 fmapMaybe f = push $ return . f
8501050
851−instance Align Event where
852− nil = EventNever
853− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
1051+instance HasSpiderTimeline x => Align (Event x) where
1052+ nil = eventNever
1053+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1054+
1055+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1056+
1057+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1058+newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
8541059
8551060--TODO: Avoid the duplication between this and R.zipDynWith
856−zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c
1061+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
8571062zipDynWith f da db =
858− let eab = align (updated da) (updated db)
1063+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
8591064 ec = flip push eab $ \o -> do
8601065 (a, b) <- case o of
8611066 This (Identity a) -> do
862− b <- readBehaviorUntracked $ current db
1067+ b <- readBehaviorUntracked $ dynamicCurrent db
8631068 return (a, b)
8641069 That (Identity b) -> do
865− a <- readBehaviorUntracked $ current da
1070+ a <- readBehaviorUntracked $ dynamicCurrent da
8661071 return (a, b)
8671072 These (Identity a) (Identity b) -> return (a, b)
8681073 return $ Just $ Identity $ f a b
869− in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec
1074+ in dynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
8701075
871−instance Monad (Dynamic Identity) where
872− {-# INLINE return #-}
873− return = pure
874− {-# INLINE (>>=) #-}
875− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
876− {-# INLINE (>>) #-}
877− _ >> y = y
878− {-# INLINE fail #-}
879− fail _ = error "Dynamic does not support 'fail'"
880−
881−newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
882−
883−unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
1076+unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
8841077unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
8851078 where x = (readV0, v')
8861079
887−newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
888−newJoinDyn d =
889− let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)
890− eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d
891− eInner = switch $ updated <$> current d
892− eBoth = coincidence $ updated . runIdentity <$> updated d
893− v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
894− in unsafeDyn readV0 v'
895−
896−--type role Behavior representational
897−data Behavior a
898− = forall p. BehaviorHold !(Hold p a)
899− | BehaviorHoldIdentity !(Hold Identity a)
900− | BehaviorConst !a
901− | BehaviorPull !(Pull a)
902− | BehaviorDynIdentity !(Dyn Identity a)
903− | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
904−
9051080-- ResultM can read behaviors and events
9061081type ResultM = EventM
9071082
@@ -909,24 +1084,19 @@ type ResultM = EventM
9091084unsafeNewIORef :: a -> b -> IORef b
9101085unsafeNewIORef _ b = unsafePerformIO $ newIORef b
9111086
912−instance Functor Event where
1087+instance HasSpiderTimeline x => Functor (Event x) where
9131088 fmap f = push $ return . Just . f
9141089
915−instance Functor Behavior where
1090+instance Functor (Behavior x) where
9161091 fmap f = pull . fmap f . readBehaviorTracked
9171092
918−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
919−push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
920−push f e = EventPush $ Push
921− { pushCompute = f
922− , pushParent = e
923− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
924− }
925−-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
1093+{-# INLINE push #-}
1094+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1095+push f e = cacheEvent (pushCheap f e)
9261096
927−{-# NOINLINE pull #-}
928−pull :: BehaviorM a -> Behavior a
929−pull a = BehaviorPull $ Pull
1097+{-# INLINABLE pull #-}
1098+pull :: BehaviorM x a -> Behavior x a
1099+pull a = behaviorPull $ Pull
9301100 { pullCompute = a
9311101 , pullValue = unsafeNewIORef a Nothing
9321102#ifdef DEBUG_NODEIDS
@@ -934,29 +1104,25 @@ pull a = BehaviorPull $ Pull
9341104#endif
9351105 }
9361106
937−{-# NOINLINE switch #-}
938−switch :: Behavior (Event a) -> Event a
939−switch a = EventSwitch $ Switch
1107+{-# INLINABLE switch #-}
1108+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1109+switch a = eventSwitch $ Switch
9401110 { switchParent = a
9411111 , switchSubscribed = unsafeNewIORef a Nothing
9421112 }
9431113
944−coincidence :: Event (Event a) -> Event a
945−coincidence a = EventCoincidence $ Coincidence
1114+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1115+coincidence a = eventCoincidence $ Coincidence
9461116 { coincidenceParent = a
9471117 , coincidenceSubscribed = unsafeNewIORef a Nothing
9481118 }
9491119
950−propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
951−propagateAndUpdateSubscribersRef subscribersRef a = do
952− propagate a subscribersRef
953−
9541120-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
955−run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b
1121+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
9561122run roots after = do
957− tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
958− spiderEnv <- SpiderHost ask
959− result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
1123+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1124+ t <- SpiderHost ask
1125+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
9601126 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
9611127 occBefore <- liftIO $ do
9621128 occBefore <- readIORef occRef
@@ -967,43 +1133,38 @@ run roots after = do
9671133 return $ Just r
9681134 else return Nothing
9691135 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
970− propagateAndUpdateSubscribersRef subscribersRef a
971− delayedRef <- EventM $ asks eventEnvDelayedMerges
1136+ propagate a subscribersRef
1137+ delayedRef <- asksEventEnv eventEnvDelayedMerges
9721138 let go = do
9731139 delayed <- liftIO $ readIORef delayedRef
9741140 case IntMap.minViewWithKey delayed of
9751141 Nothing -> return ()
9761142 Just ((currentHeight, cur), future) -> do
977− tracePropagate $ "Running height " ++ show currentHeight
1143+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
9781144 putCurrentHeight $ Height currentHeight
9791145 liftIO $ writeIORef delayedRef $! future
980− forM_ cur $ \d -> case d of
981− DelayedMerge subscribed -> do
982− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
983− case height `compare` Height currentHeight of
984− LT -> error "Somehow a merge's height has been decreased after it was scheduled"
985− GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
986− EQ -> do
987− m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
988− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! DMap.empty
989− --TODO: Assert that m is not empty
990− liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m
991− scheduleClear $ mergeSubscribedOccurrence subscribed
992− propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
1146+ sequence_ cur
9931147 go
9941148 go
9951149 putCurrentHeight maxBound
9961150 after
997− tracePropagate "Done running an event frame"
1151+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
9981152 return result
9991153
1154+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1155+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1156+ height <- liftIO $ readIORef heightRef
1157+ currentHeight <- getCurrentHeight
1158+ case height `compare` currentHeight of
1159+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1160+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1161+ EQ -> a
1162+
10001163data SomeClear = forall a. SomeClear (IORef (Maybe a))
10011164
10021165data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
10031166
1004−data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
1005−
1006−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
1167+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
10071168
10081169debugFinalize :: Bool
10091170debugFinalize = False
@@ -1022,41 +1183,37 @@ type WeakList a = [Weak a]
10221183#ifdef DEBUG
10231184withIncreasedDepth :: CanTrace x m => m a -> m a
10241185withIncreasedDepth a = do
1025− spiderEnv <- askSpiderTimeline
1026− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
1186+ spiderTimeline <- askSpiderTimelineEnv
1187+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
10271188 result <- a
1028− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
1189+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
10291190 return result
10301191#else
10311192withIncreasedDepth :: m a -> m a
10321193withIncreasedDepth = id
10331194#endif
10341195
1035−type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)
1196+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
10361197
10371198{-# INLINE tracePropagate #-}
1038−tracePropagate :: (CanTrace x m) => String -> m ()
1039−tracePropagate = traceWhen debugPropagate
1040−
1041−{-# INLINE traceSubscribe #-}
1042−traceSubscribe :: String -> IO ()
1043−traceSubscribe = when debugSubscribe . liftIO . putStrLn
1199+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1200+tracePropagate p = traceWhen p debugPropagate
10441201
10451202{-# INLINE traceInvalidate #-}
10461203traceInvalidate :: String -> IO ()
10471204traceInvalidate = when debugInvalidate . liftIO . putStrLn
10481205
10491206{-# INLINE traceWhen #-}
1050−traceWhen :: (CanTrace x m) => Bool -> String -> m ()
1051−traceWhen b message = traceMWhen b $ return message
1207+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1208+traceWhen p b message = traceMWhen p b $ return message
10521209
10531210{-# INLINE traceMWhen #-}
1054−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
1055−traceMWhen b getMessage = when b $ do
1211+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1212+traceMWhen _ b getMessage = when b $ do
10561213 message <- getMessage
10571214#ifdef DEBUG
1058− spiderEnv <- askSpiderTimeline
1059− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
1215+ spiderTimeline <- askSpiderTimelineEnv
1216+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
10601217#else
10611218 let d = 0
10621219#endif
@@ -1065,6 +1222,7 @@ traceMWhen b getMessage = when b $ do
10651222whoCreatedIORef :: IORef a -> IO [String]
10661223whoCreatedIORef (IORef a) = whoCreated $! a
10671224
1225+#ifdef DEBUG_CYCLES
10681226groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
10691227groupByHead = \case
10701228 [] -> []
@@ -1076,181 +1234,49 @@ groupByHead = \case
10761234
10771235listsToForest :: Eq a => [[a]] -> Forest a
10781236listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1079−
1080−-- | Propagate everything at the current height
1081−propagate :: a -> SubscriberList a -> EventM x ()
1082−propagate a subscribers = withIncreasedDepth $ do
1083− -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
1084− --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
1085− WeakBag.traverse subscribers $ \s -> case s of
1086− SubscriberPush compute subscribed -> {-# SCC "traversePush" #-} do
1087− tracePropagate $ "SubscriberPush" <> showNodeId subscribed
1088− occ <- runComputeM $ compute a
1089− case occ of
1090− Nothing -> return () -- No need to write a Nothing back into the Ref
1091− Just o -> do
1092− liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
1093− scheduleClear $ pushSubscribedOccurrence subscribed
1094− propagate o $ pushSubscribedSubscribers subscribed
1095− SubscriberMerge k subscribed -> {-# SCC "traverseMerge" #-} do
1096− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
1097− oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
1098− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge" <> showNodeId subscribed) k (Identity a) oldM
1099− tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1100− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! newM
1101− when (DMap.null oldM) $ do -- Only schedule the firing once
1102− height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
1103− --TODO: assertions about height
1104− currentHeight <- getCurrentHeight
1105− when (height <= currentHeight) $ do
1106− myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
1107− if height /= invalidHeight
1108− then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1109− else liftIO $ do
1110− nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
1111− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1112− error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
1113− scheduleMerge height subscribed
1114− SubscriberMergeChange subscribed -> {-# SCC "traverseMergeChange" #-} do
1115− tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
1116− defer $ SomeMergeUpdate a subscribed
1117− SubscriberFan subscribed -> {-# SCC "traverseFan" #-} do
1118− subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
1119− tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
1120− --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
1121− forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
1122− Nothing -> do
1123− tracePropagate "No subscriber for key"
1124− return ()
1125− Just subsubs -> do
1126− propagate v $ _fanSubscribedChildren_list subsubs
1127− return ()
1128− SubscriberHold h -> {-# SCC "traverseHold" #-} propagateSubscriberHold h a
1129− SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a
1130− SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do
1131− tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
1132− liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
1133− scheduleClear $ switchSubscribedOccurrence subscribed
1134− propagate a $ switchSubscribedSubscribers subscribed
1135− SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do
1136− tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
1137− outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
1138− tracePropagate $ " outerHeight = " <> show outerHeight
1139− (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
1140− tracePropagate $ " isJust occ = " <> show (isJust occ)
1141− tracePropagate $ " innerHeight = " <> show innerHeight
1142− liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
1143− scheduleClear $ coincidenceSubscribedInnerParent subscribed
1144− case occ of
1145− Nothing -> do
1146− when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
1147− writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
1148− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
1149− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
1150− Just o -> do -- Since it's already firing, no need to adjust height
1151− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
1152− scheduleClear $ coincidenceSubscribedOccurrence subscribed
1153− propagate o $ coincidenceSubscribedSubscribers subscribed
1154− SubscriberCoincidenceInner subscribed -> {-# SCC "traverseCoincidenceInner" #-} do
1155− tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
1156− occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
1157− case occ of
1158− Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
1159− Nothing -> do
1160− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
1161− scheduleClear $ coincidenceSubscribedOccurrence subscribed
1162− propagate a $ coincidenceSubscribedSubscribers subscribed
1163− SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
1237+#endif
11641238
11651239{-# INLINE propagateSubscriberHold #-}
1166−propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()
1240+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
11671241propagateSubscriberHold h a = do
1168− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
1242+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
11691243 invalidators <- liftIO $ readIORef $ holdInvalidators h
11701244 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
11711245 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1172− case {-# SCC "apply" #-} R.apply a v of
1246+ case {-# SCC "apply" #-} apply a v of
11731247 Nothing -> return ()
11741248 Just v' -> do
1175− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1249+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
11761250 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
11771251 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
11781252 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
11791253
1180−data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1181−
1182−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1183−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1184−readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1185−readBehaviorUntracked b = do
1186− holdInits <- getDeferralQueue
1187− liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1254+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
11881255
1189−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a
1256+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
11901257runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
11911258
1192−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
1259+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
11931260askInvalidator = do
11941261 (!m, _) <- BehaviorM ask
11951262 case m of
11961263 Nothing -> return Nothing
11971264 Just (!wi, _) -> return $ Just wi
11981265
1199−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
1266+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
12001267askParentsRef = do
12011268 (!m, _) <- BehaviorM ask
12021269 case m of
12031270 Nothing -> return Nothing
12041271 Just (_, !p) -> return $ Just p
12051272
1206−askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1273+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
12071274askBehaviorHoldInits = do
12081275 (_, !his) <- BehaviorM ask
12091276 return his
12101277
1211−readBehaviorTracked :: Behavior a -> BehaviorM a
1212−readBehaviorTracked b = case b of
1213− BehaviorHold h -> readHoldTracked h
1214− BehaviorHoldIdentity h -> readHoldTracked h
1215− BehaviorConst a -> return a
1216− BehaviorPull p -> do
1217− val <- liftIO $ readIORef $ pullValue p
1218− case val of
1219− Just subscribed -> do
1220− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1221− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
1222− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
1223− return $ pullSubscribedValue subscribed
1224− Nothing -> do
1225− i <- liftIO $ newInvalidatorPull p
1226− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
1227− parentsRef <- liftIO $ newIORef []
1228− holdInits <- askBehaviorHoldInits
1229− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
1230− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
1231− parents <- liftIO $ readIORef parentsRef
1232− let subscribed = PullSubscribed
1233− { pullSubscribedValue = a
1234− , pullSubscribedInvalidators = invsRef
1235− , pullSubscribedOwnInvalidator = i
1236− , pullSubscribedParents = parents
1237− }
1238− liftIO $ writeIORef (pullValue p) $ Just subscribed
1239− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1240− return a
1241− BehaviorDyn d -> readHoldTracked =<< getDynHold d
1242− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1243−
1244−{-# INLINE readHoldTracked #-}
1245−readHoldTracked :: Hold p a -> BehaviorM a
1246−readHoldTracked h = do
1247− result <- liftIO $ readIORef $ holdValue h
1248− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1249− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1250− return result
1251−
12521278{-# INLINE getDynHold #-}
1253−getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)
1279+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
12541280getDynHold d = do
12551281 mh <- liftIO $ readIORef $ unDyn d
12561282 case mh of
@@ -1262,72 +1288,30 @@ getDynHold d = do
12621288 liftIO $ writeIORef (unDyn d) $ Right h
12631289 return h
12641290
1265−readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1266−readRootSubscribed = rootSubscribedOccurrence
1267−
1268−readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)
1269−readPushSubscribed subscribed = do
1270− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1271− touch $ pushSubscribedSelf subscribed
1272− return result
1273−
1274−readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1275−readMergeSubscribed subscribed = do
1276− result <- readIORef $ mergeSubscribedOccurrence subscribed
1277− touch $ mergeSubscribedParents subscribed
1278− return result
1279−
1280−readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
1281−readFanSubscribed k fs = do
1282− parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs
1283− return $ coerce $ DMap.lookup k =<< parentOcc
1284−
1285−readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1286−readSwitchSubscribed subscribed = do
1287− result <- readIORef $ switchSubscribedOccurrence subscribed
1288− touch $ switchSubscribedOwnInvalidator subscribed
1289− return result
1290−
1291−readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)
1292−readCoincidenceSubscribed subscribed = do
1293− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1294− touch $ coincidenceSubscribedOuter subscribed
1295− --TODO: do we need to touch the inner subscriber?
1296− return result
1297−
12981291-- Always refers to 0
12991292{-# NOINLINE zeroRef #-}
13001293zeroRef :: IORef Height
13011294zeroRef = unsafePerformIO $ newIORef zeroHeight
13021295
1303−{-# INLINE subscribeHoldEvent #-}
1304−subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1305−subscribeHoldEvent h sub = do
1306− EventSubscription _ subd <- getHoldEventSubscription h
1307− sln <- liftIO $ subscribeEventSubscribed subd sub
1308− return $ EventSubscription sln subd
1309−
1310−{-# INLINE debugSubscribe #-}
1311−debugSubscribe :: Bool
1312−debugSubscribe = False
1313−
1314−
13151296type CanSubscribe x m =
1316− ( HasSpiderTimeline x m
1317− , HasCurrentHeight m
1318− , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1297+ ( HasSpiderTimeline x
1298+ , HasCurrentHeight x m
1299+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
13191300 , Defer SomeClear m -- Wiping out event firings
1320− , Defer SomeAssignment m -- Updating state
1321− , Defer SomeResetCoincidence m
1301+ , Defer (SomeAssignment x) m -- Updating state
1302+ , Defer (SomeResetCoincidence x) m
1303+ , m ~ EventM x
13221304 )
13231305
1324−getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
1306+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
13251307getRootSubscribed k r sub = do
13261308 mSubscribed <- readIORef $ rootSubscribed r
1309+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
13271310 case DMap.lookup k mSubscribed of
13281311 Just subscribed -> {-# SCC "hitRoot" #-} do
13291312 sln <- subscribeRootSubscribed subscribed sub
1330− return (sln, subscribed)
1313+ occ <- getOcc
1314+ return (sln, subscribed, occ)
13311315 Nothing -> {-# SCC "missRoot" #-} do
13321316 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
13331317 let !cached = rootSubscribed r
@@ -1339,7 +1323,7 @@ getRootSubscribed k r sub = do
13391323 let subscribed = RootSubscribed
13401324 { rootSubscribedKey = k
13411325 , rootSubscribedCachedSubscribed = cached
1342− , rootSubscribedOccurrence = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1326+ , rootSubscribedOccurrence = getOcc
13431327 , rootSubscribedSubscribers = subs
13441328 , rootSubscribedUninit = uninit
13451329 , rootSubscribedWeakSelf = weakSelf
@@ -1349,153 +1333,41 @@ getRootSubscribed k r sub = do
13491333 }
13501334 writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
13511335 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1352− return (sln, subscribed)
1336+ occ <- getOcc
1337+ return (sln, subscribed, occ)
13531338
13541339{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1355−cleanupRootSubscribed :: RootSubscribed a -> IO ()
1340+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
13561341cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
13571342 rootSubscribedUninit self
13581343 modifyIORef' cached $ DMap.delete k
13591344
13601345{-# INLINE subscribeRootSubscribed #-}
1361−subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1346+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
13621347subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
13631348
1364−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1365−{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}
1366−getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)
1367−getPushSubscribed p sub = do
1368− mSubscribed <- liftIO $ readIORef $ pushSubscribed p
1369− case mSubscribed of
1370− Just subscribed -> {-# SCC "hitPush" #-} do
1371− sln <- liftIO $ subscribePushSubscribed subscribed sub
1372− return (sln, subscribed)
1373− Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
1374− subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
1375− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1376− s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
1377− subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s
1378− parentOcc <- liftIO $ readEventSubscribed subd
1379− occ <- runComputeM $ join <$> mapM (pushCompute p) parentOcc
1380− occRef <- liftIO $ newIORef occ
1381− when (isJust occ) $ scheduleClear occRef
1382− weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"
1383− let !cached = pushSubscribed p
1384− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupPushSubscribed
1385− let subscribed = PushSubscribed
1386− { pushSubscribedCachedSubscribed = cached
1387− , pushSubscribedOccurrence = occRef
1388− , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
1389− , pushSubscribedSubscribers = subs
1390− , pushSubscribedSelf = s
1391− , pushSubscribedWeakSelf = weakSelf
1392− , pushSubscribedParent = subscription
1393−#ifdef DEBUG_NODEIDS
1394− , pushSubscribedNodeId = unsafeNodeId p
1395−#endif
1396− }
1397− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1398− liftIO $ writeIORef subscribedRef $! subscribed
1399− liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
1400− return (sln, subscribed)
1401−
1402−cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1403−cleanupPushSubscribed self = do
1404− unsubscribe $ pushSubscribedParent self
1405− writeIORef (pushSubscribedCachedSubscribed self) $ Nothing
1406−
1407−{-# INLINE subscribePushSubscribed #-}
1408−subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)
1409−subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
1410−
1411−{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}
1412−getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)
1413−getMergeSubscribed m sub = do
1414− mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
1415− case mSubscribed of
1416− Just subscribed -> {-# SCC "hitMerge" #-} do
1417− sln <- liftIO $ subscribeMergeSubscribed subscribed sub
1418− return (sln, subscribed)
1419− Nothing -> {-# SCC "missMerge" #-} do
1420− subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1421− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1422− initialParents <- readBehaviorUntracked $ current $ mergeParents m
1423− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> do
1424− s <- {-# SCC "getMergeSubscribed.a.1" #-} liftIO $ newSubscriberMerge k subscribedUnsafe
1425− subscription@(EventSubscription _ parentSubd) <- {-# SCC "getMergeSubscribed.a.2" #-} subscribe e s
1426− parentOcc <- {-# SCC "getMergeSubscribed.a.3" #-} liftIO $ readEventSubscribed parentSubd
1427− height <- {-# SCC "getMergeSubscribed.a.4" #-} liftIO $ getEventSubscribedHeight parentSubd
1428− {-# SCC "getMergeSubscribed.a.5" #-} return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)
1429− let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1430− heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1431− myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1432− myHeight = if invalidHeight `elem` heights
1433− then invalidHeight
1434− else succHeight $ heightBagMax myHeightBag
1435− currentHeight <- getCurrentHeight
1436− let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1437− then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1438− else (Nothing, dm)
1439− unless (DMap.null accum) $ do
1440− scheduleMerge myHeight subscribedUnsafe
1441− occRef <- liftIO $ newIORef occ
1442− when (isJust occ) $ scheduleClear occRef
1443− accumRef <- liftIO $ newIORef accum
1444− heightRef <- liftIO $ newIORef myHeight
1445− heightMapRef <- liftIO $ newIORef myHeightBag
1446− weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
1447− (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
1448− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1449− parentsRef <- liftIO $ newIORef $ DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1450− let !subscribed = MergeSubscribed
1451− { mergeSubscribedCachedSubscribed = mergeSubscribed m
1452− , mergeSubscribedOccurrence = occRef
1453− , mergeSubscribedAccum = accumRef
1454− , mergeSubscribedHeight = heightRef
1455− , mergeSubscribedHeightBag = heightMapRef
1456− , mergeSubscribedSubscribers = subs
1457− , mergeSubscribedChange = changeSubdRef
1458− , mergeSubscribedParents = parentsRef
1459− , mergeSubscribedWeakSelf = weakSelf
1460−#ifdef DEBUG_NODEIDS
1461− , mergeSubscribedNodeId = unsafeNodeId m
1462−#endif
1463− }
1464− defer $ SomeMergeInit subscribed $ updated $ mergeParents m
1465− liftIO $ writeIORef subscribedRef $! subscribed
1466− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1467− liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
1468− return (sln, subscribed)
1469−
1470−cleanupMergeSubscribed :: MergeSubscribed k -> IO ()
1471−cleanupMergeSubscribed subscribed = do
1472− parents <- readIORef $ mergeSubscribedParents subscribed
1473− forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp
1474− -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty
1475− writeIORef (mergeSubscribedCachedSubscribed subscribed) $ Nothing -- Get rid of the cached subscribed
1476−
1477−{-# INLINE subscribeMergeSubscribed #-}
1478−subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))
1479−subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
1480−
1481−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}
1482−getFanSubscribed :: (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderTimeline x m, GCompare k) => k a -> Fan k -> Subscriber a -> m (SubscriberListTicket a, FanSubscribed k)
1349+{-# INLINABLE getFanSubscribed #-}
1350+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
14831351getFanSubscribed k f sub = do
14841352 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
14851353 case mSubscribed of
1486− Just subscribed -> {-# SCC "hitFan" #-} do
1487− sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1488− return (sln, subscribed)
1354+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1355+ sln <- subscribeFanSubscribed k subscribed sub
1356+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1357+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
14891358 Nothing -> {-# SCC "missFan" #-} do
14901359 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
14911360 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
14921361 s <- liftIO $ newSubscriberFan subscribedUnsafe
1493− subscription <- subscribe (fanParent f) s
1362+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
14941363 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
14951364 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
14961365 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1366+ occRef <- liftIO $ newIORef parentOcc
1367+ when (isJust parentOcc) $ scheduleClear occRef
14971368 let subscribed = FanSubscribed
14981369 { fanSubscribedCachedSubscribed = fanSubscribed f
1370+ , fanSubscribedOccurrence = occRef
14991371 , fanSubscribedParent = subscription
15001372 , fanSubscribedSubscribers = subscribersRef
15011373#ifdef DEBUG_NODEIDS
@@ -1507,9 +1379,9 @@ getFanSubscribed k f sub = do
15071379 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
15081380 liftIO $ writeIORef subscribedRef $! subscribed
15091381 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1510− return (slnForSub, subscribed)
1382+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
15111383
1512−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1384+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
15131385cleanupFanSubscribed (k, subscribed) = do
15141386 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15151387 let reducedSubscribers = DMap.delete k subscribers
@@ -1521,7 +1393,7 @@ cleanupFanSubscribed (k, subscribed) = do
15211393 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
15221394
15231395{-# INLINE subscribeFanSubscribed #-}
1524−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)
1396+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
15251397subscribeFanSubscribed k subscribed sub = do
15261398 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15271399 case DMap.lookup k subscribers of
@@ -1529,18 +1401,19 @@ subscribeFanSubscribed k subscribed sub = do
15291401 let !self = (k, subscribed)
15301402 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
15311403 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1532− writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeEventSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers
1404+ writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers
15331405 return sln
15341406 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
15351407
1536−{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1537−getSwitchSubscribed :: (Defer SomeHoldInit m, Defer SomeAssignment m, Defer SomeMergeInit m, Defer SomeClear m, Defer SomeResetCoincidence m, HasCurrentHeight m, HasSpiderTimeline x m) => Switch a -> Subscriber a -> m (SubscriberListTicket a, SwitchSubscribed a)
1408+{-# INLINABLE getSwitchSubscribed #-}
1409+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
15381410getSwitchSubscribed s sub = do
15391411 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
15401412 case mSubscribed of
1541− Just subscribed -> {-# SCC "hitSwitch" #-} do
1542− sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1543− return (sln, subscribed)
1413+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1414+ sln <- subscribeSwitchSubscribed subscribed sub
1415+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1416+ return (sln, subscribed, occ)
15441417 Nothing -> {-# SCC "missSwitch" #-} do
15451418 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
15461419 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1551,12 +1424,11 @@ getSwitchSubscribed s sub = do
15511424 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
15521425 holdInits <- getDeferralQueue
15531426 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1554− subscription@(EventSubscription _ subd) <- subscribe e mySub
1427+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1428+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
15551429 subscriptionRef <- liftIO $ newIORef subscription
1556− parentOcc <- liftIO $ readEventSubscribed subd
15571430 occRef <- liftIO $ newIORef parentOcc
15581431 when (isJust parentOcc) $ scheduleClear occRef
1559− heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
15601432 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
15611433 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
15621434 let !subscribed = SwitchSubscribed
@@ -1577,32 +1449,32 @@ getSwitchSubscribed s sub = do
15771449 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
15781450 liftIO $ writeIORef subscribedRef $! subscribed
15791451 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1580− return (slnForSub, subscribed)
1452+ return (slnForSub, subscribed, parentOcc)
15811453
1582−cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1454+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
15831455cleanupSwitchSubscribed subscribed = do
15841456 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
15851457 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
15861458 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
15871459
15881460{-# INLINE subscribeSwitchSubscribed #-}
1589−subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1461+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
15901462subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
15911463
1592−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1593−getCoincidenceSubscribed :: forall x a m. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderTimeline x m) => Coincidence a -> Subscriber a -> m (SubscriberListTicket a, CoincidenceSubscribed a)
1464+{-# INLINABLE getCoincidenceSubscribed #-}
1465+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
15941466getCoincidenceSubscribed c sub = do
15951467 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
15961468 case mSubscribed of
1597− Just subscribed -> {-# SCC "hitCoincidence" #-} do
1598− sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1599− return (sln, subscribed)
1469+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1470+ sln <- subscribeCoincidenceSubscribed subscribed sub
1471+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1472+ return (sln, subscribed, occ)
16001473 Nothing -> {-# SCC "missCoincidence" #-} do
16011474 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
16021475 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
16031476 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1604− outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
1605− outerOcc <- liftIO $ readEventSubscribed outerSubd
1477+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
16061478 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
16071479 (occ, height, mInnerSubd) <- case outerOcc of
16081480 Nothing -> return (Nothing, outerHeight, Nothing)
@@ -1632,35 +1504,158 @@ getCoincidenceSubscribed c sub = do
16321504 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
16331505 liftIO $ writeIORef subscribedRef $! subscribed
16341506 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1635− return (slnForSub, subscribed)
1507+ return (slnForSub, subscribed, occ)
16361508
1637−cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1509+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
16381510cleanupCoincidenceSubscribed subscribed = do
16391511 unsubscribe $ coincidenceSubscribedOuterParent subscribed
16401512 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
16411513
16421514{-# INLINE subscribeCoincidenceSubscribed #-}
1643−subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1515+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
16441516subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
16451517
16461518{-# INLINE merge #-}
1647−merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
1648−merge m = EventMerge $ Merge
1649− { mergeParents = m
1650− , mergeSubscribed = unsafeNewIORef m Nothing
1651− }
1652−
1653−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1654−
1655−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1519+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1520+merge d = cacheEvent (mergeCheap d)
1521+
1522+{-# INLINE [1] mergeCheap #-}
1523+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1524+mergeCheap d = Event $ \sub -> do
1525+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1526+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1527+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1528+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1529+ parentsRef <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1530+ let scheduleSelf height = scheduleMerge' height heightRef $ do
1531+ m <- liftIO $ readIORef accumRef
1532+ liftIO $ writeIORef accumRef $! DMap.empty
1533+ --TODO: Assert that m is not empty
1534+ subscriberPropagate sub m
1535+ invalidateMyHeight = do
1536+ oldHeight <- readIORef heightRef
1537+ when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1538+ writeIORef heightRef $! invalidHeight
1539+ subscriberInvalidateHeight sub oldHeight
1540+ revalidateMyHeight = do
1541+ currentHeight <- readIORef heightRef
1542+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1543+ heights <- readIORef heightBagRef
1544+ parents <- readIORef parentsRef
1545+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1546+ case heightBagSize heights `compare` DMap.size parents of
1547+ LT -> return ()
1548+ EQ -> do
1549+ let height = succHeight $ heightBagMax heights
1550+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1551+ writeIORef heightRef $! height
1552+ subscriberRecalculateHeight sub height
1553+ GT -> error $ "revalidateMergeHeight: more heights than parents for Merge"
1554+ subscriber :: forall a. k a -> Subscriber x a
1555+ subscriber k = Subscriber
1556+ { subscriberPropagate = \a -> do
1557+ oldM <- liftIO $ readIORef accumRef
1558+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1559+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1560+ liftIO $ writeIORef accumRef $! newM
1561+ when (DMap.null oldM) $ do -- Only schedule the firing once
1562+ height <- liftIO $ readIORef heightRef
1563+ --TODO: assertions about height
1564+ currentHeight <- getCurrentHeight
1565+ when (height <= currentHeight) $ do
1566+ if height /= invalidHeight
1567+ then do
1568+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1569+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1570+ else liftIO $ do
1571+#ifdef DEBUG_CYCLES
1572+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1573+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1574+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1575+#else
1576+ let cycleInfo = ""
1577+#endif
1578+ error $ "Causality loop found" <> cycleInfo
1579+ scheduleSelf height
1580+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1581+ modifyIORef' heightBagRef $ heightBagRemove old
1582+ invalidateMyHeight
1583+ , subscriberRecalculateHeight = \new -> do
1584+ modifyIORef' heightBagRef $ heightBagAdd new
1585+ revalidateMyHeight
1586+ }
1587+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1588+ let s = subscriber k
1589+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1590+ height <- liftIO $ getEventSubscribedHeight parentSubd
1591+ return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1592+ let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1593+ heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1594+ myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1595+ myHeight = if invalidHeight `elem` heights
1596+ then invalidHeight
1597+ else succHeight $ heightBagMax myHeightBag
1598+ currentHeight <- getCurrentHeight
1599+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1600+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1601+ else (Nothing, dm)
1602+ unless (DMap.null accum) $ do
1603+ scheduleSelf myHeight
1604+ occRef <- liftIO $ newIORef occ
1605+ when (isJust occ) $ scheduleClear occRef
1606+ liftIO $ writeIORef accumRef $! accum
1607+ liftIO $ writeIORef heightRef $! myHeight
1608+ liftIO $ writeIORef heightBagRef $! myHeightBag
1609+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1610+ liftIO $ writeIORef parentsRef $! DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1611+ let updateMe (PatchDMap p) = do
1612+ oldParents <- liftIO $ readIORef parentsRef
1613+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1614+ (mOldSubd, newPs) <- case me of
1615+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1616+ Just e -> do
1617+ let s = subscriber k
1618+ subscription@(EventSubscription _ subd) <- subscribe e s
1619+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1620+ let newParent = MergeSubscribedParent subscription
1621+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1622+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1623+ forM_ mOldSubd $ \oldSubd -> do
1624+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1625+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1626+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1627+ (subscriptionsToKill, newParents) <- foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1628+ liftIO $ writeIORef parentsRef $! newParents
1629+ return subscriptionsToKill
1630+ defer $ SomeMergeInit $ do
1631+ let s = Subscriber
1632+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1633+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1634+ defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight
1635+ , subscriberInvalidateHeight = \_ -> return ()
1636+ , subscriberRecalculateHeight = \_ -> return ()
1637+ }
1638+ (EventSubscription _ changeSubd, change) <- subscribeAndRead (dynamicUpdated d) s
1639+ forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight
1640+ liftIO $ writeIORef changeSubdRef (s, changeSubd)
1641+ let unsubscribeAll = do
1642+ parents <- readIORef parentsRef
1643+ forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s
1644+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1645+ , occ
1646+ )
1647+
1648+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
1649+
1650+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
16561651fan e =
16571652 let f = Fan
16581653 { fanParent = e
16591654 , fanSubscribed = unsafeNewIORef e Nothing
16601655 }
1661− in EventSelector $ \k -> EventFan k f
1656+ in EventSelector $ \k -> eventFan k f
16621657
1663−runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1658+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()
16641659runHoldInits holdInitRef mergeInitRef = do
16651660 holdInits <- liftIO $ readIORef holdInitRef
16661661 mergeInits <- liftIO $ readIORef mergeInitRef
@@ -1668,26 +1663,14 @@ runHoldInits holdInitRef mergeInitRef = do
16681663 liftIO $ writeIORef holdInitRef []
16691664 liftIO $ writeIORef mergeInitRef []
16701665 mapM_ initHold holdInits
1671− mapM_ initMerge mergeInits
1666+ mapM_ unSomeMergeInit mergeInits
16721667 runHoldInits holdInitRef mergeInitRef
16731668
1674−initHold :: SomeHoldInit -> EventM x ()
1669+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
16751670initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
16761671
1677−initMerge :: SomeMergeInit -> EventM x ()
1678−initMerge (SomeMergeInit subscribed changed) = do
1679− changeSub <- liftIO $ newSubscriberMergeChange subscribed
1680− EventSubscription _ changeSubd <- subscribe changed changeSub
1681− change <- liftIO $ readEventSubscribed changeSubd
1682− forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1683− liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
1684−
1685−-- | Run an event action outside of a frame
1686−runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1687−runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1688− -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now
1689− pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)
1690− {-# SCC "cleanups" #-} sequence_ pendingCleanups
1672+newEventEnv :: IO (EventEnv x)
1673+newEventEnv = do
16911674 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
16921675 holdInitRef <- newIORef []
16931676 mergeUpdateRef <- newIORef []
@@ -1696,50 +1679,48 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
16961679 toClearRef <- newIORef []
16971680 toClearRootRef <- newIORef []
16981681 coincidenceInfosRef <- newIORef []
1699− delayedRef <- liftIO $ newIORef IntMap.empty
1700− let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1682+ delayedRef <- newIORef IntMap.empty
1683+ return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1684+
1685+clearEventEnv :: EventEnv x -> IO ()
1686+clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
1687+ writeIORef toAssignRef []
1688+ writeIORef holdInitRef []
1689+ writeIORef mergeUpdateRef []
1690+ writeIORef mergeInitRef []
1691+ writeIORef heightRef zeroHeight
1692+ writeIORef toClearRef []
1693+ writeIORef toClearRootRef []
1694+ writeIORef coincidenceInfosRef []
1695+ writeIORef delayedRef IntMap.empty
1696+
1697+-- | Run an event action outside of a frame
1698+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1699+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
1700+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
17011701 let go = do
17021702 result <- a
1703− runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1703+ runHoldInits (eventEnvHoldInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
17041704 return result
1705− result <- runEventM go env
1706− toClear <- readIORef toClearRef
1705+ result <- runEventM go
1706+ toClear <- readIORef $ eventEnvClears env
17071707 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1708− toClearRoot <- readIORef toClearRootRef
1708+ toClearRoot <- readIORef $ eventEnvRootClears env
17091709 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1710− toAssign <- readIORef toAssignRef
1710+ toAssign <- readIORef $ eventEnvAssignments env
17111711 toReconnectRef <- newIORef []
1712− coincidenceInfos <- readIORef coincidenceInfosRef
1712+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
17131713 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
17141714 writeIORef vRef v
17151715 when debugInvalidate $ putStrLn $ "Invalidating Hold"
17161716 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1717− mergeUpdates <- readIORef mergeUpdateRef
1718− writeIORef mergeUpdateRef []
1719− let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1720− updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do
1721− oldParents <- readIORef $ mergeSubscribedParents m
1722− let f (subscriptionsToKill, ps) (k :=> Compose me) = do
1723− (mOldSubd, newPs) <- case me of
1724− Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1725− Just e -> do
1726− s <- liftIO $ newSubscriberMerge k m
1727− subscription@(EventSubscription _ subd) <- subscribe e s
1728− let newParent = MergeSubscribedParent subscription s
1729− newParentHeight <- liftIO $ getEventSubscribedHeight subd
1730− liftIO $ addMergeHeight newParentHeight m
1731− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1732− forM_ mOldSubd $ \oldSubd -> do
1733− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1734− liftIO $ removeMergeHeight oldHeight m
1735− return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1736− (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1737− writeIORef (mergeSubscribedParents m) $! newParents
1738− return subscriptionsToKill
1717+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
1718+ writeIORef (eventEnvMergeUpdates env) []
17391719 when debugPropagate $ putStrLn "Updating merges"
1740− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1720+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
17411721 when debugPropagate $ putStrLn "Updating merges done"
17421722 toReconnect <- readIORef toReconnectRef
1723+ clearEventEnv env
17431724 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
17441725 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
17451726 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
@@ -1749,12 +1730,12 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17491730 wi' <- mkWeakPtrWithDebug i "wi'"
17501731 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
17511732 writeIORef (switchSubscribedBehaviorParents subscribed) []
1752− writeIORef holdInitRef [] --TODO: Should we reuse this?
1753− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1754− runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
1733+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
1734+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
1735+ runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
17551736 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
17561737 sub <- newSubscriberSwitch subscribed
1757− subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --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
1738+ subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --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
17581739 {-
17591740 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
17601741 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1763,9 +1744,9 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17631744 _ -> "something else"
17641745 -}
17651746 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1766− return $ SomeEventSubscription oldSubscription
1767− forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1768− forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1747+ return oldSubscription
1748+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
1749+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
17691750 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
17701751 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
17711752 parentHeight <- getEventSubscribedHeight subd'
@@ -1773,13 +1754,12 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17731754 when (parentHeight /= myHeight) $ do
17741755 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
17751756 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1776− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> do
1777− invalidateMergeHeight m --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
1757+ mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
17781758 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
17791759 unsubscribe subscription
17801760 mapM_ invalidateCoincidenceHeight mcs
17811761 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1782− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1762+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
17831763 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
17841764 height <- calculateSwitchHeight subscribed
17851765 updateSwitchHeight height subscribed
@@ -1795,10 +1775,12 @@ zeroHeight = Height 0
17951775invalidHeight :: Height
17961776invalidHeight = Height (-1000)
17971777
1778+#ifdef DEBUG_CYCLES
17981779-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
17991780{-# INLINE invalidHeightBeingTraversed #-}
18001781invalidHeightBeingTraversed :: Height
18011782invalidHeightBeingTraversed = Height (-1001)
1783+#endif
18021784
18031785{-# INLINE succHeight #-}
18041786succHeight :: Height -> Height
@@ -1807,121 +1789,14 @@ succHeight h@(Height a) =
18071789 then invalidHeight
18081790 else Height $ succ a
18091791
1810−invalidateSubscriberHeight :: Height -> Subscriber a -> IO ()
1811−invalidateSubscriberHeight old s = case s of
1812− SubscriberPush _ subscribed -> do
1813− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1814− WeakBag.traverse (pushSubscribedSubscribers subscribed) $ invalidateSubscriberHeight old
1815− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1816− SubscriberMerge _ subscribed -> do
1817− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1818− removeMergeHeight old subscribed
1819− invalidateMergeHeight subscribed
1820− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1821− SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
1822− SubscriberFan subscribed -> do
1823− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1824− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1825− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
1826− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1827− SubscriberHold _ -> return ()
1828− SubscriberHoldIdentity _ -> return ()
1829− SubscriberSwitch subscribed -> do
1830− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1831− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1832− when (oldHeight /= invalidHeight) $ do
1833− writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1834− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1835− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1836− SubscriberCoincidenceOuter subscribed -> do
1837− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1838− invalidateCoincidenceHeight subscribed
1839− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1840− SubscriberCoincidenceInner subscribed -> do
1841− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1842− invalidateCoincidenceHeight subscribed
1843− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1844− SubscriberHandle -> return ()
1845−
1846−removeMergeHeight :: Height -> MergeSubscribed k -> IO ()
1847−removeMergeHeight oldParentHeight subscribed = do
1848− when debugInvalidateHeight $ putStrLn $ "removeMergeHeight: " <> show oldParentHeight <> " Merge" <> showNodeId subscribed
1849− oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1850− let newHeights = heightBagRemove oldParentHeight oldHeights
1851− writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1852−
1853−invalidateMergeHeight :: MergeSubscribed k -> IO ()
1854−invalidateMergeHeight subscribed = do
1855− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1856− -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1857− when (oldHeight /= invalidHeight) $ do
1858− writeIORef (mergeSubscribedHeight subscribed) $! invalidHeight
1859− WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1860−
1861−addMergeHeight :: Height -> MergeSubscribed k -> IO ()
1862−addMergeHeight newParentHeight subscribed = do
1863− when debugInvalidateHeight $ putStrLn $ "addMergeHeight: " <> show newParentHeight <> " Merge" <> showNodeId subscribed
1864− oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1865− let newHeights = heightBagAdd newParentHeight oldHeights
1866− writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1867−
1868−revalidateMergeHeight :: MergeSubscribed k -> IO ()
1869−revalidateMergeHeight subscribed = do
1870− currentHeight <- readIORef $ mergeSubscribedHeight subscribed
1871− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1872− heights <- readIORef $ mergeSubscribedHeightBag subscribed
1873− parents <- readIORef $ mergeSubscribedParents subscribed
1874− -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1875− case heightBagSize heights `compare` DMap.size parents of
1876− LT -> return ()
1877− EQ -> do
1878− let height = succHeight $ heightBagMax heights
1879− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1880− writeIORef (mergeSubscribedHeight subscribed) $! height
1881− WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1882− GT -> error $ "revalidateMergeHeight: more heights than parents for Merge" <> showNodeId subscribed
1883−
1884−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1792+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
18851793invalidateCoincidenceHeight subscribed = do
18861794 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
18871795 when (oldHeight /= invalidHeight) $ do
18881796 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
18891797 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
18901798
1891−recalculateSubscriberHeight :: Height -> Subscriber a -> IO ()
1892−recalculateSubscriberHeight new s = case s of
1893− SubscriberPush _ subscribed -> do
1894− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1895− WeakBag.traverse (pushSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1896− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1897− SubscriberMerge _ subscribed -> do
1898− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1899− addMergeHeight new subscribed
1900− revalidateMergeHeight subscribed
1901− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1902− SubscriberMergeChange _ -> return ()
1903− SubscriberFan subscribed -> do
1904− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1905− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1906− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
1907− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1908− SubscriberHold _ -> return ()
1909− SubscriberHoldIdentity _ -> return ()
1910− SubscriberSwitch subscribed -> do
1911− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1912− updateSwitchHeight new subscribed
1913− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1914− SubscriberCoincidenceOuter subscribed -> do
1915− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1916− recalculateCoincidenceHeight subscribed
1917− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1918− SubscriberCoincidenceInner subscribed -> do
1919− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1920− recalculateCoincidenceHeight subscribed
1921− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1922− SubscriberHandle -> return ()
1923−
1924−updateSwitchHeight :: Height -> SwitchSubscribed a -> IO ()
1799+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
19251800updateSwitchHeight new subscribed = do
19261801 oldHeight <- readIORef $ switchSubscribedHeight subscribed
19271802 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
@@ -1929,7 +1804,7 @@ updateSwitchHeight new subscribed = do
19291804 writeIORef (switchSubscribedHeight subscribed) $! new
19301805 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
19311806
1932−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1807+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
19331808recalculateCoincidenceHeight subscribed = do
19341809 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
19351810 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
@@ -1938,18 +1813,18 @@ recalculateCoincidenceHeight subscribed = do
19381813 writeIORef (coincidenceSubscribedHeight subscribed) $! height
19391814 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
19401815
1941−calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1816+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
19421817calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
19431818
1944−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1819+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
19451820calculateCoincidenceHeight subscribed = do
19461821 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
19471822 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
19481823 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
19491824
1950−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1825+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
19511826
1952−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1827+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
19531828invalidate toReconnectRef wis = do
19541829 forM_ wis $ \wi -> do
19551830 mi <- deRefWeak wi
@@ -1975,174 +1850,95 @@ invalidate toReconnectRef wis = do
19751850-- Reflex integration
19761851--------------------------------------------------------------------------------
19771852
1978−-- | The default, global Spider environment
1979−type Spider = SpiderTimeline Global
1980−
1981−-- | Designates the default, global Spider timeline
1982−data Global
1983−
1984−{-# NOINLINE globalSpiderTimeline #-}
1985−globalSpiderTimeline :: SpiderTimeline Global
1986−globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
1987−
1988−-- | Stores all global data relevant to a particular Spider timeline; only one
1989−-- value should exist for each type @x@
1990−data SpiderTimeline x = SpiderTimeline
1991− { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])
1992− , _spiderEnv_lock :: !(MVar ())
1993− , _spiderEnv_cleanups :: !(IORef [IO ()])
1994−#ifdef DEBUG
1995− , _spiderEnv_depth :: !(IORef Int)
1853+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1854+-- When we're specializing, we include this from Reflex.Class instead, because
1855+-- it needs access to these types; when we're not, we want them here, so our
1856+-- instance isn't an orphan instance.
1857+#include "SpiderTimeline.include.hs"
1858+#include "SpiderTimelineHost.include.hs"
19961859#endif
1997− }
1998−type role SpiderTimeline nominal
19991860
2000−instance GEq SpiderTimeline where
2001− a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
2002− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimeline can't have two different 'x' arguments
2003− else Nothing
2004−
2005−unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)
2006−unsafeNewSpiderTimeline = do
2007− toUnsubscribe <- newIORef []
1861+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
1862+unsafeNewSpiderTimelineEnv = do
20081863 lock <- newMVar ()
2009− cleanups <- newIORef []
1864+ env <- newEventEnv
20101865#ifdef DEBUG
20111866 depthRef <- newIORef 0
20121867#endif
2013− return $ SpiderTimeline
2014− { _spiderEnv_toUnsubscribe = toUnsubscribe
2015− , _spiderEnv_lock = lock
2016− , _spiderEnv_cleanups = cleanups
1868+ return $ SpiderTimelineEnv
1869+ { _spiderTimeline_lock = lock
1870+ , _spiderTimeline_eventEnv = env
20171871#ifdef DEBUG
2018− , _spiderEnv_depth = depthRef
1872+ , _spiderTimeline_depth = depthRef
20191873#endif
20201874 }
20211875
2022−-- | Create a new SpiderTimeline
2023−newSpiderTimeline :: IO (Some SpiderTimeline)
1876+-- | Create a new SpiderTimelineEnv
1877+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
20241878newSpiderTimeline = withSpiderTimeline (pure . Some.This)
20251879
20261880-- | Pass a new timeline to the given function.
2027−withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r
2028−withSpiderTimeline k = unsafeNewSpiderTimeline >>= k
1881+withSpiderTimeline :: (forall x. SpiderTimelineEnv x -> IO r) -> IO r
1882+withSpiderTimeline k = unsafeNewSpiderTimelineEnv >>= k
20291883
2030−newtype SpiderPullM x a = SpiderPullM (BehaviorM a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1884+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
20311885
2032−newtype SpiderPushM x a = SpiderPushM (ComputeM a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1886+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
20331887
2034−instance R.Reflex (SpiderTimeline x) where
2035− newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
2036− newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event a }
2037− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
2038− newtype Incremental (SpiderTimeline x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
1888+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1889+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
1890+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
1891+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
1892+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
1893+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
1894+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
20391895 type PullM (SpiderTimeline x) = SpiderPullM x
20401896 type PushM (SpiderTimeline x) = SpiderPushM x
20411897 {-# INLINABLE never #-}
2042− never = SpiderEvent EventNever
1898+ never = SpiderEvent eventNever
20431899 {-# INLINABLE constant #-}
2044− constant = SpiderBehavior . BehaviorConst
2045− {-# INLINABLE push #-}
1900+ constant = SpiderBehavior . behaviorConst
1901+ {-# INLINE push #-}
20461902 push f = SpiderEvent . push (coerce f) . unSpiderEvent
20471903 {-# INLINABLE pull #-}
20481904 pull = SpiderBehavior . pull . coerce
20491905 {-# INLINABLE merge #-}
2050− merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k Event)
1906+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
20511907 {-# INLINABLE fan #-}
20521908 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
20531909 {-# INLINABLE switch #-}
2054− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderTimeline x) a) -> Behavior (Event a)) . unSpiderBehavior
1910+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
20551911 {-# INLINABLE coincidence #-}
2056− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderTimeline x) a) -> Event (Event a)) . unSpiderEvent
1912+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
20571913 {-# INLINABLE current #-}
2058− current = SpiderBehavior . current . unSpiderDynamic
1914+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
20591915 {-# INLINABLE updated #-}
2060− updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
1916+ updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic
20611917 {-# INLINABLE unsafeBuildDynamic #-}
2062− unsafeBuildDynamic readV0 v' = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (coerce readV0) $ addIdentity $ unSpiderEvent v'
1918+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'
20631919 {-# INLINABLE unsafeBuildIncremental #-}
2064− unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1920+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
20651921 {-# INLINABLE mergeIncremental #-}
2066− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderTimeline x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental
1922+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
20671923 {-# INLINABLE currentIncremental #-}
2068− currentIncremental = SpiderBehavior . current . unSpiderIncremental
1924+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
20691925 {-# INLINABLE updatedIncremental #-}
2070− updatedIncremental = SpiderEvent . updated . unSpiderIncremental
1926+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
20711927 {-# INLINABLE incrementalToDynamic #-}
2072− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
2073− c <- readBehaviorUntracked $ current i
2074− return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'
2075−
2076−instance R.MonadSample (SpiderTimeline x) (EventM x) where
2077− {-# INLINABLE sample #-}
2078− sample (SpiderBehavior b) = readBehaviorUntracked b
2079−
2080−instance R.MonadHold (SpiderTimeline x) (EventM x) where
2081− {-# INLINABLE hold #-}
2082− hold = holdSpiderEventM
2083− {-# INLINABLE holdDyn #-}
2084− holdDyn = holdDynSpiderEventM
2085− {-# INLINABLE holdIncremental #-}
2086− holdIncremental = holdIncrementalSpiderEventM
2087−
2088−holdSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)
2089−holdSpiderEventM v0 e = fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2090−
2091−holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)
2092−holdDynSpiderEventM v0 e = fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2093−
2094−holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderTimeline x) (p a) -> EventM x (R.Incremental (SpiderTimeline x) p a)
2095−holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2096−
2097−instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where
2098− {-# INLINABLE hold #-}
2099− hold v0 e = R.runHostFrame $ R.hold v0 e
2100− {-# INLINABLE holdDyn #-}
2101− holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
2102− {-# INLINABLE holdIncremental #-}
2103− holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
2104−
2105−instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where
2106− {-# INLINABLE sample #-}
2107− sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2108−
2109−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2110− {-# INLINABLE sample #-}
2111− sample = coerce . readBehaviorTracked . unSpiderBehavior
2112−
2113−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2114− {-# INLINABLE sample #-}
2115− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2116−
2117−instance R.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2118− {-# INLINABLE hold #-}
2119− hold v0 e = R.current <$> R.holdDyn v0 e
2120− {-# INLINABLE holdDyn #-}
2121− holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e
2122− {-# INLINABLE holdIncremental #-}
2123− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . DynamicHold <$> hold v0 e
2124−
2125−data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
2126−newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
2127−
2128−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2129− {-# INLINABLE subscribeEvent #-}
2130− subscribeEvent e = SpiderHostFrame $ do
2131− subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2132− return $ SpiderEventHandle subscription
2133−
2134−instance R.ReflexHost (SpiderTimeline x) where
2135− type EventTrigger (SpiderTimeline x) = RootTrigger
2136− type EventHandle (SpiderTimeline x) = SpiderEventHandle
2137− type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2138−
2139−instance R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where
2140− {-# INLINABLE readEvent #-}
2141− readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do
2142− let EventSubscription sln subscribed = unSpiderEventHandle h
2143− result <- readEventSubscribed subscribed
2144− touch sln
2145− return result
1928+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
1929+ c <- readBehaviorUntracked $ dynamicCurrent i
1930+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
1931+ eventCoercion Coercion = Coercion
1932+ behaviorCoercion Coercion = Coercion
1933+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
1934+#endif
1935+
1936+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
1937+
1938+data SpiderEventHandle x a = SpiderEventHandle
1939+ { spiderEventHandleSubscription :: EventSubscription x
1940+ , spiderEventHandleValue :: IORef (Maybe a)
1941+ }
21461942
21471943instance MonadRef (EventM x) where
21481944 type Ref (EventM x) = Ref IO
@@ -2158,7 +1954,7 @@ instance MonadAtomicRef (EventM x) where
21581954 atomicModifyRef r f = liftIO $ atomicModifyRef r f
21591955
21601956-- | The monad for actions that manipulate a Spider timeline identified by @x@
2161−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimeline x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1957+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
21621958
21631959instance Monad (SpiderHost x) where
21641960 {-# INLINABLE (>>=) #-}
@@ -2173,11 +1969,11 @@ instance Monad (SpiderHost x) where
21731969-- | Run an action affecting the global Spider timeline; this will be guarded by
21741970-- a mutex for that timeline
21751971runSpiderHost :: SpiderHost Global a -> IO a
2176−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline
1972+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
21771973
21781974-- | Run an action affecting a given Spider timeline; this will be guarded by a
21791975-- mutex for that timeline
2180−runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a
1976+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
21811977runSpiderHostForTimeline (SpiderHost a) = runReaderT a
21821978
21831979newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
@@ -2192,27 +1988,12 @@ instance Monad (SpiderHostFrame x) where
21921988 {-# INLINABLE fail #-}
21931989 fail s = SpiderHostFrame $ fail s
21941990
2195−instance R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2196− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2197−
2198−addIdentity :: Event a -> Event (Identity a)
2199−--addIdentity = fmap Identity
2200−addIdentity = unsafeCoerce
2201−
2202−instance R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2203− {-# INLINABLE hold #-}
2204− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2205− {-# INLINABLE holdDyn #-}
2206− holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2207− {-# INLINABLE holdIncremental #-}
2208− holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2209−
2210−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
1991+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
22111992newEventWithTriggerIO f = do
22121993 es <- newFanEventWithTriggerIO $ \Refl -> f
22131994 return $ select es Refl
22141995
2215−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
1996+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
22161997newFanEventWithTriggerIO f = do
22171998 occRef <- newIORef DMap.empty
22181999 subscribedRef <- newIORef DMap.empty
@@ -2221,48 +2002,10 @@ newFanEventWithTriggerIO f = do
22212002 , rootSubscribed = subscribedRef
22222003 , rootInit = f
22232004 }
2224− return $ EventSelector $ \k -> EventRoot k r
2225−
2226−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2227− newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2228− newFanEventWithTrigger f = SpiderHost $ lift $ do
2229− es <- newFanEventWithTriggerIO f
2230− return $ R.EventSelector $ SpiderEvent . select es
2231−
2232−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2233− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2234− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2235− es <- newFanEventWithTriggerIO f
2236− return $ R.EventSelector $ SpiderEvent . select es
2237−
2238−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2239− {-# INLINABLE subscribeEvent #-}
2240− subscribeEvent = subscribeEventSpiderHost
2241−
2242−subscribeEventSpiderHost :: R.Event (SpiderTimeline x) a -> SpiderHost x (R.EventHandle (SpiderTimeline x) a)
2243−subscribeEventSpiderHost e = do
2244− subscription <- runFrame $ subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2245− return $ SpiderEventHandle subscription
2005+ return $ EventSelector $ \k -> eventRoot k r
22462006
22472007newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
22482008
2249−instance R.MonadSample (SpiderTimeline x) (ReadPhase x) where
2250− {-# INLINABLE sample #-}
2251− sample = ReadPhase . R.sample
2252−
2253−instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where
2254− {-# INLINABLE hold #-}
2255− hold v0 e = ReadPhase $ R.hold v0 e
2256− {-# INLINABLE holdDyn #-}
2257− holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2258− {-# INLINABLE holdIncremental #-}
2259− holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
2260−
2261−instance R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2262− type ReadPhase (SpiderHost x) = ReadPhase x
2263− fireEventsAndRead es (ReadPhase a) = run es a
2264− runHostFrame = runFrame . runSpiderHostFrame
2265−
22662009instance MonadRef (SpiderHost x) where
22672010 type Ref (SpiderHost x) = Ref IO
22682011 newRef = SpiderHost . newRef
@@ -2281,9 +2024,6 @@ instance MonadRef (SpiderHostFrame x) where
22812024instance MonadAtomicRef (SpiderHostFrame x) where
22822025 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
22832026
2284−--------------------------------------------------------------------------------
2285−-- Deprecated items
2286−--------------------------------------------------------------------------------
2287−
2288−{-# DEPRECATED SpiderEnv "Use 'SpiderTimeline' instead" #-}
2289−type SpiderEnv = SpiderTimeline
2027+instance PrimMonad (SpiderHostFrame x) where
2028+ type PrimState (SpiderHostFrame x) = PrimState IO
2029+ primitive = SpiderHostFrame . EventM . primitive