@@ -2,7 +2,6 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE EmptyDataDecls #-}
5−{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE FunctionalDependencies #-}
@@ -18,6 +17,10 @@
18{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
22+{-# OPTIONS_GHC -fno-warn-orphans #-}
21-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
24-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
22-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
25-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
23module Reflex.Spider.Internal where
26module Reflex.Spider.Internal where
@@ -31,46 +34,57 @@ import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
31import Control.Monad.Primitive
34import Control.Monad.Primitive
32import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
35import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
33import Control.Monad.Ref
36import Control.Monad.Ref
34−import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
35import Data.Align
37import Data.Align
36import Data.Coerce
38import Data.Coerce
37import Data.Dependent.Map (DMap, DSum (..))
39import Data.Dependent.Map (DMap, DSum (..))
38import qualified Data.Dependent.Map as DMap
40import qualified Data.Dependent.Map as DMap
39import Data.Foldable hiding (concat, elem, sequence_)
41import Data.Foldable hiding (concat, elem, sequence_)
40import Data.Function
42import Data.Function
41−import Data.Functor.Compose
43+import Data.Functor.Constant
44+import Data.Functor.Misc
45+import Data.Functor.Product
42import Data.GADT.Compare
46import Data.GADT.Compare
43import Data.IntMap.Strict (IntMap)
47import Data.IntMap.Strict (IntMap)
44import qualified Data.IntMap.Strict as IntMap
48import qualified Data.IntMap.Strict as IntMap
45import Data.IORef
49import Data.IORef
46import Data.List hiding (foldl')
50import Data.List hiding (foldl')
47−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
48−import qualified Data.List.NonEmpty as NonEmpty
49import Data.Maybe
51import Data.Maybe
50−import Data.Monoid (mempty, (<>))
52+import Data.Monoid ((<>))
51import Data.Some (Some)
54import Data.Some (Some)
52import qualified Data.Some as Some
55import qualified Data.Some as Some
53import Data.These
56import Data.These
54import Data.Traversable
57import Data.Traversable
55−import Data.Tree (Forest, Tree (..), drawForest)
56import Data.Word
58import Data.Word
57import GHC.IORef (IORef (..))
60import GHC.IORef (IORef (..))
58import GHC.Stack
61import GHC.Stack
62+import Reflex.FunctorMaybe
59import System.IO.Unsafe
63import System.IO.Unsafe
60import System.Mem.Weak
64import System.Mem.Weak
61import Unsafe.Coerce
65import Unsafe.Coerce
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)
63import Data.WeakBag (WeakBag, WeakBagTicket)
75import Data.WeakBag (WeakBag, WeakBagTicket)
64import qualified Data.WeakBag as WeakBag
76import qualified Data.WeakBag as WeakBag
77+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78+import Data.Type.Coercion
79+import qualified Reflex.Class
65import qualified Reflex.Class as R
80import qualified Reflex.Class as R
66−import qualified Reflex.Host.Class as R
81+import qualified Reflex.Host.Class
68-- Note: must come last to silence warnings due to AMP on GHC < 7.10
85-- Note: must come last to silence warnings due to AMP on GHC < 7.10
69import Prelude hiding (any, concat, mapM, mapM_, sequence)
86import Prelude hiding (any, concat, mapM, mapM_, sequence)
71−type SubscriberList a = WeakBag (Subscriber a)
72−type SubscriberListTicket a = WeakBagTicket (Subscriber a)
74debugPropagate :: Bool
88debugPropagate :: Bool
76debugInvalidateHeight :: Bool
90debugInvalidateHeight :: Bool
@@ -90,35 +104,32 @@ debugInvalidate = True
90class HasNodeId a where
104class HasNodeId a where
91 getNodeId :: a -> Int
105 getNodeId :: a -> Int
93−instance HasNodeId (Hold p a) where
107+instance HasNodeId (Hold x p a) where
94 getNodeId = holdNodeId
108 getNodeId = holdNodeId
96−instance HasNodeId (PushSubscribed a b) where
110+instance HasNodeId (PushSubscribed x a b) where
97 getNodeId = pushSubscribedNodeId
111 getNodeId = pushSubscribedNodeId
99−instance HasNodeId (SwitchSubscribed a) where
113+instance HasNodeId (SwitchSubscribed x a) where
100 getNodeId = switchSubscribedNodeId
114 getNodeId = switchSubscribedNodeId
102−instance HasNodeId (MergeSubscribed a) where
103− getNodeId = mergeSubscribedNodeId
105−instance HasNodeId (FanSubscribed a) where
116+instance HasNodeId (FanSubscribed x a) where
106 getNodeId = fanSubscribedNodeId
117 getNodeId = fanSubscribedNodeId
108−instance HasNodeId (CoincidenceSubscribed a) where
119+instance HasNodeId (CoincidenceSubscribed x a) where
109 getNodeId = coincidenceSubscribedNodeId
120 getNodeId = coincidenceSubscribedNodeId
111−instance HasNodeId (RootSubscribed a) where
122+instance HasNodeId (RootSubscribed x a) where
112 getNodeId = rootSubscribedNodeId
123 getNodeId = rootSubscribedNodeId
114−instance HasNodeId (Pull a) where
125+instance HasNodeId (Pull x a) where
115 getNodeId = pullNodeId
126 getNodeId = pullNodeId
117{-# INLINE showNodeId #-}
128{-# INLINE showNodeId #-}
118showNodeId :: HasNodeId a => a -> String
129showNodeId :: HasNodeId a => a -> String
119showNodeId = ("#"<>) . show . getNodeId
130showNodeId = ("#"<>) . show . getNodeId
121−showSubscriberType :: Subscriber a -> String
132+showSubscriberType :: Subscriber x a -> String
122showSubscriberType = \case
133showSubscriberType = \case
123 SubscriberPush _ _ -> "SubscriberPush"
134 SubscriberPush _ _ -> "SubscriberPush"
124 SubscriberMerge _ _ -> "SubscriberMerge"
135 SubscriberMerge _ _ -> "SubscriberMerge"
@@ -131,7 +142,7 @@ showSubscriberType = \case
131 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
142 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
132 SubscriberHandle -> "SubscriberHandle"
143 SubscriberHandle -> "SubscriberHandle"
134−showEventType :: Event a -> String
145+showEventType :: Event x a -> String
135showEventType = \case
146showEventType = \case
136 EventRoot _ _ -> "EventRoot"
147 EventRoot _ _ -> "EventRoot"
137 EventNever -> "EventNever"
148 EventNever -> "EventNever"
@@ -179,153 +190,359 @@ unsafeNodeId a = unsafePerformIO $ do
180--------------------------------------------------------------------------------
191--------------------------------------------------------------------------------
182−data Event a
193+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
183− = forall k. GCompare k => EventRoot !(k a) !(Root k)
194+
184− | EventNever
195+{-# INLINE subscribeAndRead #-}
185− | forall b. EventPush !(Push b a)
196+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
186− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
197+subscribeAndRead = unEvent
187− | forall k. GCompare k => EventFan !(k a) !(Fan k)
198+
188− | EventSwitch !(Switch a)
199+{-# RULES
189− | EventCoincidence !(Coincidence a)
200+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
190− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
201+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
191− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
202+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
192− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
203+ #-}
193− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
204+{- RULES
194−
205+ "subscribeAndRead/cacheEvent" forall e. subscribeAndRead (cacheEvent e) = subscribeAndRead e
195−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
206+ #-}
196−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
207+
197−subscribe e sub = case e of
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
220+ occ' <- join <$> mapM (runComputeM . f) occ
221+ return (subscription, occ')
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))
231+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
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
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
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
250+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
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
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
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)
278+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
279+cleanupCacheSubscribed self = do
280+ unsubscribe $ _cacheSubscribed_parent self
281+ writeIORef (_cacheSubscribed_cached self) Nothing
283+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
284+subscribe e s = fst <$> subscribeAndRead e s
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
291+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
293+eventRoot :: GCompare k => k a -> Root x k -> Event x a
198− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
294+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
199− EventNever -> return $ EventSubscription Nothing EventSubscribedNever
295+
200− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
296+eventNever :: Event x a
201− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
297+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
202− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
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
302+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
203− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
303+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
204− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
304+
205− EventHold h -> subscribeHoldEvent h sub
305+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
206− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
306+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
207− EventHoldIdentity h -> subscribeHoldEvent h sub
307+
308+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
208− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
309+eventHold !h = Event $ subscribeHoldEvent h
210− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
311+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
211− wrap tag getSpecificSubscribed = do
312+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
212− (sln, subd) <- getSpecificSubscribed sub
213− return $ EventSubscription (Just sln) $ tag subd
215{-# INLINE subscribeCoincidenceInner #-}
314{-# 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)
217subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
316subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
218 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
317 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
219− subscription@(EventSubscription _ innerSubd) <- subscribe inner subInner
318+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
220− innerOcc <- liftIO $ readEventSubscribed innerSubd
221 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
319 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
222 let height = max innerHeight outerHeight
320 let height = max innerHeight outerHeight
223 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
321 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
224 return (innerOcc, height, innerSubd)
322 return (innerOcc, height, innerSubd)
324+--------------------------------------------------------------------------------
326+--------------------------------------------------------------------------------
328+data Subscriber x a = Subscriber
329+ { subscriberPropagate :: !(a -> EventM x ())
330+ , subscriberInvalidateHeight :: !(Height -> IO ())
331+ , subscriberRecalculateHeight :: !(Height -> IO ())
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.
341+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
342+-- the weak pointer to it in some cases.
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 ()
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_
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"
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"
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
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"
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
432+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
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"
447+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
448+invalidateSubscriberHeight = flip subscriberInvalidateHeight
450+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
451+recalculateSubscriberHeight = flip subscriberRecalculateHeight
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
226--------------------------------------------------------------------------------
460--------------------------------------------------------------------------------
227-- EventSubscribed
461-- EventSubscribed
228--------------------------------------------------------------------------------
462--------------------------------------------------------------------------------
230−data EventSubscribed a
467+data EventSubscribed x = EventSubscribed
231− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
468+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
232− | EventSubscribedNever
469+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
233− | forall b. EventSubscribedPush !(PushSubscribed b a)
470+#ifdef DEBUG_CYCLES
234− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
471+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
235− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
472+ , eventSubscribedHasOwnHeightRef :: !Bool
236− | EventSubscribedSwitch !(SwitchSubscribed a)
473+ , eventSubscribedWhoCreated :: !(IO [String])
237− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
474+#endif
239−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
476+
240−readEventSubscribed = \case
477+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
241− EventSubscribedRoot rs -> readRootSubscribed rs
478+eventSubscribedRoot !r = EventSubscribed
242− EventSubscribedNever -> return Nothing
479+ { eventSubscribedHeightRef = zeroRef
243− EventSubscribedPush ps -> readPushSubscribed ps
480+ , eventSubscribedRetained = toAny r
244− EventSubscribedMerge ms -> readMergeSubscribed ms
481+#ifdef DEBUG_CYCLES
245− EventSubscribedFan k fs -> readFanSubscribed k fs
482+ , eventSubscribedGetParents = return []
246− EventSubscribedSwitch ss -> readSwitchSubscribed ss
483+ , eventSubscribedHasOwnHeightRef = False
247− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
484+ , eventSubscribedWhoCreated = return ["root"]
249−{-# INLINE subscribeEventSubscribed #-}
486+ }
250−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
487+
251−subscribeEventSubscribed es sub = case es of
488+eventSubscribedNever :: EventSubscribed x
252− EventSubscribedRoot r -> do
489+eventSubscribedNever = EventSubscribed
253− traceSubscribe $ "subscribeEventSubscribed Root"
490+ { eventSubscribedHeightRef = zeroRef
254− Just <$> subscribeRootSubscribed r sub
491+ , eventSubscribedRetained = toAny ()
255− EventSubscribedNever -> do
492+#ifdef DEBUG_CYCLES
256− traceSubscribe $ "subscribeEventSubscribed Never"
493+ , eventSubscribedGetParents = return []
257− return Nothing
494+ , eventSubscribedHasOwnHeightRef = False
258− EventSubscribedPush subscribed -> do
495+ , eventSubscribedWhoCreated = return ["never"]
259− traceSubscribe $ "subscribeEventSubscribed Push"
496+#endif
260− Just <$> subscribePushSubscribed subscribed sub
497+ }
261− EventSubscribedFan k subscribed -> do
498+
262− traceSubscribe $ "subscribeEventSubscribed Fan"
499+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
263− Just <$> subscribeFanSubscribed k subscribed sub
500+eventSubscribedFan !subscribed = EventSubscribed
264− EventSubscribedMerge subscribed -> do
501+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
265− traceSubscribe $ "subscribeEventSubscribed Merge"
502+ , eventSubscribedRetained = toAny subscribed
266− Just <$> subscribeMergeSubscribed subscribed sub
503+#ifdef DEBUG_CYCLES
267− EventSubscribedSwitch subscribed -> do
504+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
268− traceSubscribe $ "subscribeEventSubscribed Switch"
505+ , eventSubscribedHasOwnHeightRef = False
269− Just <$> subscribeSwitchSubscribed subscribed sub
506+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
270− EventSubscribedCoincidence subscribed -> do
507+#endif
271− traceSubscribe $ "subscribeEventSubscribed Coincidence"
508+ }
272− Just <$> subscribeCoincidenceSubscribed subscribed sub
509+
273−
510+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
511+eventSubscribedSwitch !subscribed = EventSubscribed
512+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
513+ , eventSubscribedRetained = toAny subscribed
274−{-# INLINE eventSubscribedGetParents #-}
515+ , eventSubscribedGetParents = do
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
516+ s <- readIORef $ switchSubscribedCurrentParent subscribed
286− return [Some.This $ _eventSubscription_subscribed s]
517+ return [Some.This $ _eventSubscription_subscribed s]
287− EventSubscribedCoincidence subscribed -> do
518+ , eventSubscribedHasOwnHeightRef = True
519+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
523+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
524+eventSubscribedCoincidence !subscribed = EventSubscribed
525+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
526+ , eventSubscribedRetained = toAny subscribed
528+ , eventSubscribedGetParents = do
288− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
529+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
289− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
530+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
290− innerParents = maybeToList $ fmap Some.This innerSubscription
531+ innerParents = maybeToList $ fmap Some.This innerSubscription
291− return $ outerParent : innerParents
532+ return $ outerParent : innerParents
292−
533+ , eventSubscribedHasOwnHeightRef = True
534+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
293−getEventSubscribedHeight :: EventSubscribed a -> IO Height
538+getEventSubscribedHeight :: EventSubscribed x -> IO Height
294getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
539getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
296−{-# INLINE eventSubscribedHeightRef #-}
541+#ifdef DEBUG_CYCLES
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
307−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
542+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
308−whoCreatedEventSubscribed = \case
543+whoCreatedEventSubscribed = eventSubscribedWhoCreated
309− EventSubscribedRoot _ -> return ["root"]
544+
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
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
328−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
545+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
329walkInvalidHeightParents s0 = do
546walkInvalidHeightParents s0 = do
330 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
547 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
331 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
548 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
@@ -335,18 +552,115 @@ walkInvalidHeightParents s0 = do
335 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
552 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
336 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
553 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
337 return subscribers
554 return subscribers
557+{-# INLINE subscribeHoldEvent #-}
558+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
559+subscribeHoldEvent = subscribeAndRead . holdEvent
339--------------------------------------------------------------------------------
561--------------------------------------------------------------------------------
340-- EventSubscription
562-- EventSubscription
341--------------------------------------------------------------------------------
563--------------------------------------------------------------------------------
343−data EventSubscription a = EventSubscription
565+data EventSubscription x = EventSubscription
344− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
566+ { _eventSubscription_unsubscribe :: !(IO ())
345− , _eventSubscription_subscribed :: !(EventSubscribed a)
567+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
348−unsubscribe :: EventSubscription a -> IO ()
570+unsubscribe :: EventSubscription x -> IO ()
349−unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
571+unsubscribe (EventSubscription u _) = u
573+--------------------------------------------------------------------------------
575+--------------------------------------------------------------------------------
577+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
579+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
580+behaviorHold !h = Behavior $ readHoldTracked h
582+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
583+behaviorHoldIdentity = behaviorHold
585+behaviorConst :: a -> Behavior x a
586+behaviorConst !a = Behavior $ return a
588+behaviorPull :: Pull x a -> Behavior x a
589+behaviorPull !p = Behavior $ do
590+ val <- liftIO $ readIORef $ pullValue p
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
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
611+ liftIO $ writeIORef (pullValue p) $ Just subscribed
612+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
615+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
616+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
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) :))
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
632+--------------------------------------------------------------------------------
634+--------------------------------------------------------------------------------
636+data Dynamic x p = Dynamic
637+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
638+ , dynamicUpdated :: !(Event x p)
641+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
642+dynamicHold !h = Dynamic
643+ { dynamicCurrent = behaviorHold h
644+ , dynamicUpdated = eventHold h
647+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
648+dynamicHoldIdentity = dynamicHold
650+dynamicConst :: PatchTarget p -> Dynamic x p
651+dynamicConst !a = Dynamic
652+ { dynamicCurrent = behaviorConst a
653+ , dynamicUpdated = eventNever
656+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
657+dynamicDyn !d = Dynamic
658+ { dynamicCurrent = behaviorDyn d
659+ , dynamicUpdated = eventDyn d
662+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
663+dynamicDynIdentity = dynamicDyn
351--------------------------------------------------------------------------------
665--------------------------------------------------------------------------------
352-- Combinators
666-- Combinators
@@ -356,31 +670,56 @@ unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
356--representational so we can use coerce
670--representational so we can use coerce
358--type role Hold representational
672--type role Hold representational
359−data Hold p a
673+data Hold x p
360− = Hold { holdValue :: !(IORef a)
674+ = Hold { holdValue :: !(IORef (PatchTarget p))
361− , holdInvalidators :: !(IORef [Weak Invalidator])
675+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
676+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
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
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
363#ifdef DEBUG_NODEIDS
678#ifdef DEBUG_NODEIDS
364 , holdNodeId :: Int
679 , holdNodeId :: Int
685+{-# NOINLINE globalSpiderTimelineEnv #-}
686+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
687+!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
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)
695+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
698+type role SpiderTimelineEnv nominal
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
368data EventEnv x
705data EventEnv x
369− = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)
370− , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe
706+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
371− , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe
707+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
372− , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])
708+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
373− , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe
709+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
374 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
710 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
375 , eventEnvRootClears :: !(IORef [SomeRootClear])
711 , eventEnvRootClears :: !(IORef [SomeRootClear])
376 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
712 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
377− , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe
713+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
378− , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
714+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
381{-# INLINE runEventM #-}
717{-# INLINE runEventM #-}
382−runEventM :: EventM x a -> EventEnv x -> IO a
718+runEventM :: EventM x a -> IO a
383−runEventM = runReaderT . unEventM
719+runEventM = unEventM
721+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
722+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
385class MonadIO m => Defer a m where
724class MonadIO m => Defer a m where
386 getDeferralQueue :: m (IORef [a])
725 getDeferralQueue :: m (IORef [a])
@@ -391,91 +730,91 @@ defer a = do
391 q <- getDeferralQueue
730 q <- getDeferralQueue
392 liftIO $ modifyIORef' q (a:)
731 liftIO $ modifyIORef' q (a:)
394−instance Defer SomeAssignment (EventM x) where
733+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
395 {-# INLINE getDeferralQueue #-}
734 {-# INLINE getDeferralQueue #-}
396− getDeferralQueue = EventM $ asks eventEnvAssignments
735+ getDeferralQueue = asksEventEnv eventEnvAssignments
398−instance Defer SomeHoldInit (EventM x) where
737+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
399 {-# INLINE getDeferralQueue #-}
738 {-# INLINE getDeferralQueue #-}
400− getDeferralQueue = EventM $ asks eventEnvHoldInits
739+ getDeferralQueue = asksEventEnv eventEnvHoldInits
402−instance Defer SomeHoldInit BehaviorM where
741+instance Defer (SomeHoldInit x) (BehaviorM x) where
403 {-# INLINE getDeferralQueue #-}
742 {-# INLINE getDeferralQueue #-}
404 getDeferralQueue = BehaviorM $ asks snd
743 getDeferralQueue = BehaviorM $ asks snd
406−instance Defer SomeMergeUpdate (EventM x) where
745+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
407 {-# INLINE getDeferralQueue #-}
746 {-# INLINE getDeferralQueue #-}
408− getDeferralQueue = EventM $ asks eventEnvMergeUpdates
747+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
410−instance Defer SomeMergeInit (EventM x) where
749+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
411 {-# INLINE getDeferralQueue #-}
750 {-# INLINE getDeferralQueue #-}
412− getDeferralQueue = EventM $ asks eventEnvMergeInits
751+ getDeferralQueue = asksEventEnv eventEnvMergeInits
414−class HasCurrentHeight m where
753+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
415 getCurrentHeight :: m Height
754 getCurrentHeight :: m Height
416− scheduleMerge :: Height -> MergeSubscribed a -> m ()
755+ scheduleMerge :: Height -> EventM x () -> m ()
418−instance HasCurrentHeight (EventM x) where
757+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
419 {-# INLINE getCurrentHeight #-}
758 {-# INLINE getCurrentHeight #-}
420− getCurrentHeight = EventM $ do
759+ getCurrentHeight = do
421− heightRef <- asks eventEnvCurrentHeight
760+ heightRef <- asksEventEnv eventEnvCurrentHeight
422 liftIO $ readIORef heightRef
761 liftIO $ readIORef heightRef
423 {-# INLINE scheduleMerge #-}
762 {-# INLINE scheduleMerge #-}
424− scheduleMerge height subscribed = EventM $ do
763+ scheduleMerge height subscribed = do
425− delayedRef <- asks eventEnvDelayedMerges
764+ delayedRef <- asksEventEnv eventEnvDelayedMerges
426− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]
765+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
428−class HasSpiderTimeline x m | m -> x where
429− -- | Retrieve the current SpiderTimeline
430− askSpiderTimeline :: m (SpiderTimeline x)
432−instance HasSpiderTimeline x (EventM x) where
767+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
433− {-# INLINE askSpiderTimeline #-}
768+class x ~ Global => HasSpiderTimeline x where
434− askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline
769+#else
770+class HasSpiderTimeline x where
772+ -- | Retrieve the current SpiderTimelineEnv
773+ spiderTimeline :: SpiderTimelineEnv x
436−instance HasSpiderTimeline x (SpiderHost x) where
775+instance HasSpiderTimeline Global where
437− {-# INLINE askSpiderTimeline #-}
776+ spiderTimeline = globalSpiderTimelineEnv
438− askSpiderTimeline = SpiderHost ask
440−putCurrentHeight :: Height -> EventM x ()
778+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
441−putCurrentHeight h = EventM $ do
779+putCurrentHeight h = do
442− heightRef <- asks eventEnvCurrentHeight
780+ heightRef <- asksEventEnv eventEnvCurrentHeight
443 liftIO $ writeIORef heightRef $! h
781 liftIO $ writeIORef heightRef $! h
445−instance Defer SomeClear (EventM x) where
783+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
446 {-# INLINE getDeferralQueue #-}
784 {-# INLINE getDeferralQueue #-}
447− getDeferralQueue = EventM $ asks eventEnvClears
785+ getDeferralQueue = asksEventEnv eventEnvClears
449{-# INLINE scheduleClear #-}
787{-# INLINE scheduleClear #-}
450scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
788scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
451scheduleClear r = defer $ SomeClear r
789scheduleClear r = defer $ SomeClear r
453−instance Defer SomeRootClear (EventM x) where
791+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
454 {-# INLINE getDeferralQueue #-}
792 {-# INLINE getDeferralQueue #-}
455− getDeferralQueue = EventM $ asks eventEnvRootClears
793+ getDeferralQueue = asksEventEnv eventEnvRootClears
457{-# INLINE scheduleRootClear #-}
795{-# INLINE scheduleRootClear #-}
458scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
796scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
459scheduleRootClear r = defer $ SomeRootClear r
797scheduleRootClear r = defer $ SomeRootClear r
461−instance Defer SomeResetCoincidence (EventM x) where
799+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
462 {-# INLINE getDeferralQueue #-}
800 {-# INLINE getDeferralQueue #-}
463− getDeferralQueue = EventM $ asks eventEnvResetCoincidences
801+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
465-- Note: hold cannot examine its event until after the phase is over
803-- 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) #-}
804+{- SPECIALIZE hold :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
467−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}
805+{-# INLINE [1] hold #-}
468−hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)
806+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
469hold v0 e = do
807hold v0 e = do
470 valRef <- liftIO $ newIORef v0
808 valRef <- liftIO $ newIORef v0
471 invsRef <- liftIO $ newIORef []
809 invsRef <- liftIO $ newIORef []
472− parentRef <- liftIO $ newIORef $ Left e
810+ parentRef <- liftIO $ newIORef Nothing
473#ifdef DEBUG_NODEIDS
811#ifdef DEBUG_NODEIDS
474 nodeId <- liftIO newNodeId
812 nodeId <- liftIO newNodeId
476 let h = Hold
814 let h = Hold
477 { holdValue = valRef
815 { holdValue = valRef
478 , holdInvalidators = invsRef
816 , holdInvalidators = invsRef
479 , holdParent = parentRef
818 , holdParent = parentRef
480#ifdef DEBUG_NODEIDS
819#ifdef DEBUG_NODEIDS
481 , holdNodeId = nodeId
820 , holdNodeId = nodeId
@@ -485,37 +824,37 @@ hold v0 e = do
487{-# INLINE getHoldEventSubscription #-}
826{-# 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)
489getHoldEventSubscription h = do
828getHoldEventSubscription h = do
490 ep <- liftIO $ readIORef $ holdParent h
829 ep <- liftIO $ readIORef $ holdParent h
491 case ep of
830 case ep of
492− Right subd -> return subd
831+ Just subd -> return subd
493− Left e -> do
832+ Nothing -> do
494 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
834 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)
496 liftIO $ writeIORef subscriptionRef $! subscription
836 liftIO $ writeIORef subscriptionRef $! subscription
497− occ <- liftIO $ readEventSubscribed subd
498 case occ of
837 case occ of
499 Nothing -> return ()
838 Nothing -> return ()
500 Just o -> do
839 Just o -> do
501 old <- liftIO $ readIORef $ holdValue h
840 old <- liftIO $ readIORef $ holdValue h
502− case R.apply o old of
841+ case apply o old of
503 Nothing -> return ()
842 Nothing -> return ()
504 Just new -> do
843 Just new -> do
505 -- Need to evaluate these so that we don't retain the Hold itself
844 -- Need to evaluate these so that we don't retain the Hold itself
506 v <- liftIO $ evaluate $ holdValue h
845 v <- liftIO $ evaluate $ holdValue h
507 i <- liftIO $ evaluate $ holdInvalidators h
846 i <- liftIO $ evaluate $ holdInvalidators h
508 defer $ SomeAssignment v i new
847 defer $ SomeAssignment v i new
509− liftIO $ writeIORef (holdParent h) $ Right subscription
848+ liftIO $ writeIORef (holdParent h) $ Just subscription
510 return subscription
849 return subscription
512−type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])
851+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
514--type role BehaviorM representational
853--type role BehaviorM representational
515-- BehaviorM can sample behaviors
854-- 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)
518−instance Monad BehaviorM where
857+instance Monad (BehaviorM x) where
519 {-# INLINE (>>=) #-}
858 {-# INLINE (>>=) #-}
520 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
859 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
521 {-# INLINE (>>) #-}
860 {-# INLINE (>>) #-}
@@ -525,94 +864,74 @@ instance Monad BehaviorM where
525 {-# INLINE fail #-}
864 {-# INLINE fail #-}
526 fail s = BehaviorM $ fail s
865 fail s = BehaviorM $ fail s
528−data BehaviorSubscribed a
867+data BehaviorSubscribed x a
529− = forall p. BehaviorSubscribedHold (Hold p a)
868+ = forall p. BehaviorSubscribedHold (Hold x p)
530− | BehaviorSubscribedPull (PullSubscribed a)
869+ | BehaviorSubscribedPull (PullSubscribed x a)
532−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
871+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
534--type role PullSubscribed representational
873--type role PullSubscribed representational
535−data PullSubscribed a
874+data PullSubscribed x a
536 = PullSubscribed { pullSubscribedValue :: !a
875 = PullSubscribed { pullSubscribedValue :: !a
537− , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])
876+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
538− , pullSubscribedOwnInvalidator :: !Invalidator
877+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
539− , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
878+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
542--type role Pull representational
881--type role Pull representational
543−data Pull a
882+data Pull x a
544− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
883+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
545− , pullCompute :: !(BehaviorM a)
884+ , pullCompute :: !(BehaviorM x a)
546#ifdef DEBUG_NODEIDS
885#ifdef DEBUG_NODEIDS
547 , pullNodeId :: Int
886 , pullNodeId :: Int
551−data Invalidator
890+data Invalidator x
552− = forall a. InvalidatorPull (Pull a)
891+ = forall a. InvalidatorPull (Pull x a)
553− | forall a. InvalidatorSwitch (SwitchSubscribed a)
892+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
555−data RootSubscribed a = forall k. GCompare k => RootSubscribed
894+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
556 { rootSubscribedKey :: !(k a)
895 { rootSubscribedKey :: !(k a)
557− , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root
896+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
558− , rootSubscribedSubscribers :: !(SubscriberList a)
897+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
559 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
898 , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
560 , rootSubscribedUninit :: IO ()
899 , 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?
562#ifdef DEBUG_NODEIDS
901#ifdef DEBUG_NODEIDS
563 , rootSubscribedNodeId :: Int
902 , rootSubscribedNodeId :: Int
567−data Root (k :: * -> *)
906+data Root x (k :: * -> *)
568 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
907 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
569− , rootSubscribed :: !(IORef (DMap k RootSubscribed))
908+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
570− , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
909+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
573−data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)
912+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
575−data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)
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 ())
579−data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)
920+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
581-- EventM can do everything BehaviorM can, plus create holds
922-- 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
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
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)
593− , pushSubscribedNodeId :: Int
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)
599−instance Defer SomeHoldInit ComputeM where
927+instance Defer (SomeHoldInit x) (ComputeM x) where
600 getDeferralQueue = ComputeM ask
928 getDeferralQueue = ComputeM ask
602−{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}
930+{-# INLINABLE runComputeM #-}
603−runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a
931+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
604runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
932runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
606−data Push a b
934+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
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?
612−data MergeSubscribedParent k a = MergeSubscribedParent !(EventSubscription a) !(Subscriber a)
614−mergeSubscribedParentSubscription :: MergeSubscribedParent k a -> EventSubscription a
615−mergeSubscribedParentSubscription (MergeSubscribedParent es _) = es
617data HeightBag = HeightBag
936data HeightBag = HeightBag
618 { _heightBag_size :: {-# UNPACK #-} !Int
937 { _heightBag_size :: {-# UNPACK #-} !Int
@@ -656,252 +975,108 @@ heightBagVerify b@(HeightBag s c) = if
656heightBagVerify = id
975heightBagVerify = id
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)))
670− , mergeSubscribedNodeId :: Int
674−--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
676− = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
677− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
680−data FanSubscribedChildren k a = FanSubscribedChildren
978+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
681− { _fanSubscribedChildren_list :: !(SubscriberList a)
979+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
682− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed k)
980+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
683− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
981+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
686−data FanSubscribed k
984+data FanSubscribed (x :: *) k
687− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
985+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
986+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
688− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
987+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
689− , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
988+ , fanSubscribedParent :: !(EventSubscription x)
690#ifdef DEBUG_NODEIDS
989#ifdef DEBUG_NODEIDS
691 , fanSubscribedNodeId :: Int
990 , fanSubscribedNodeId :: Int
695−data Fan k
994+data Fan x k
696− = Fan { fanParent :: !(Event (DMap k Identity))
995+ = Fan { fanParent :: !(Event x (DMap k Identity))
697− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
996+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
700−data SwitchSubscribed a
999+data SwitchSubscribed x a
701− = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
1000+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
702 , switchSubscribedOccurrence :: !(IORef (Maybe a))
1001 , switchSubscribedOccurrence :: !(IORef (Maybe a))
703 , switchSubscribedHeight :: !(IORef Height)
1002 , switchSubscribedHeight :: !(IORef Height)
704− , switchSubscribedSubscribers :: !(SubscriberList a)
1003+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
705− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
1004+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
706− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
1005+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
707− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
1006+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
708− , switchSubscribedParent :: !(Behavior (Event a))
1007+ , switchSubscribedParent :: !(Behavior x (Event x a))
709− , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
1008+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
710− , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
1009+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
711#ifdef DEBUG_NODEIDS
1010#ifdef DEBUG_NODEIDS
712 , switchSubscribedNodeId :: Int
1011 , switchSubscribedNodeId :: Int
716−data Switch a
1015+data Switch x a
717− = Switch { switchParent :: !(Behavior (Event a))
1016+ = Switch { switchParent :: !(Behavior x (Event x a))
718− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
1017+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
721{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1020{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
722−data CoincidenceSubscribed a
1021+data CoincidenceSubscribed x a
723− = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
1022+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
724 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1023 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
725− , coincidenceSubscribedSubscribers :: !(SubscriberList a)
1024+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
726 , coincidenceSubscribedHeight :: !(IORef Height)
1025 , coincidenceSubscribedHeight :: !(IORef Height)
727− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
1026+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
728− , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
1027+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
729− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
1028+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
730− , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
1029+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
731#ifdef DEBUG_NODEIDS
1030#ifdef DEBUG_NODEIDS
732 , coincidenceSubscribedNodeId :: Int
1031 , coincidenceSubscribedNodeId :: Int
736−data Coincidence a
1035+data Coincidence x a
737− = Coincidence { coincidenceParent :: !(Event (Event a))
1036+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
738− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
1037+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x 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)
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.
759−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
760−-- the weak pointer to it in some cases.
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
768− "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
770−{-# NOINLINE newSubscriberHold #-}
771−newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
772−newSubscriberHold h = return $! SubscriberHold h
774−{-# NOINLINE newSubscriberHoldIdentity #-}
775−newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
776−newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
778−{-# NOINLINE newSubscriberMerge #-}
779−newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
780−newSubscriberMerge k subd = return $! SubscriberMerge k subd
782−{-# NOINLINE newSubscriberMergeChange #-}
783−newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
784−newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
786−{-# NOINLINE newSubscriberFan #-}
787−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
788−newSubscriberFan subd = return $! SubscriberFan subd
790−{-# NOINLINE newSubscriberSwitch #-}
791−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
792−newSubscriberSwitch subd = return $! SubscriberSwitch subd
794−{-# NOINLINE newSubscriberCoincidenceOuter #-}
795−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
796−newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
798−{-# NOINLINE newSubscriberCoincidenceInner #-}
799−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
800−newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
802{-# NOINLINE newInvalidatorSwitch #-}
1040{-# NOINLINE newInvalidatorSwitch #-}
803−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
1041+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
804newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1042newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
806{-# NOINLINE newInvalidatorPull #-}
1044{-# NOINLINE newInvalidatorPull #-}
807−newInvalidatorPull :: Pull a -> IO Invalidator
1045+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
808newInvalidatorPull p = return $! InvalidatorPull p
1046newInvalidatorPull p = return $! InvalidatorPull p
811− = DynamicHold !(Hold p a)
812− | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
814− | DynamicDyn !(Dyn p a)
815− | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
817−{-# INLINE current #-}
818−current :: R.Patch p => Dynamic p a -> Behavior a
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
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)
830− DynamicHold h -> EventHold h
831− DynamicHoldIdentity h -> EventHoldIdentity h
832− DynamicConst _ -> EventNever
833− DynamicDyn d -> EventDyn d
834− DynamicDynIdentity d -> EventDynIdentity d
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)
839−instance Functor (Dynamic Identity) where
842−instance Applicative (Dynamic Identity) where
844− (<*>) = zipDynWith ($)
845− (*>) = zipDynWith (flip const)
846− (<*) = zipDynWith const
848−instance R.FunctorMaybe Event where
1048+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
849 fmapMaybe f = push $ return . f
1049 fmapMaybe f = push $ return . f
851−instance Align Event where
1051+instance HasSpiderTimeline x => Align (Event x) where
852− nil = EventNever
1052+ nil = eventNever
853− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
1053+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1055+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
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)
855--TODO: Avoid the duplication between this and R.zipDynWith
1060--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)
857zipDynWith f da db =
1062zipDynWith f da db =
858− let eab = align (updated da) (updated db)
1063+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
859 ec = flip push eab $ \o -> do
1064 ec = flip push eab $ \o -> do
860 (a, b) <- case o of
1065 (a, b) <- case o of
861 This (Identity a) -> do
1066 This (Identity a) -> do
862− b <- readBehaviorUntracked $ current db
1067+ b <- readBehaviorUntracked $ dynamicCurrent db
863 return (a, b)
1068 return (a, b)
864 That (Identity b) -> do
1069 That (Identity b) -> do
865− a <- readBehaviorUntracked $ current da
1070+ a <- readBehaviorUntracked $ dynamicCurrent da
866 return (a, b)
1071 return (a, b)
867 These (Identity a) (Identity b) -> return (a, b)
1072 These (Identity a) (Identity b) -> return (a, b)
868 return $ Just $ Identity $ f a b
1073 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
871−instance Monad (Dynamic Identity) where
872− {-# INLINE return #-}
874− {-# INLINE (>>=) #-}
875− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
879− fail _ = error "Dynamic does not support 'fail'"
881−newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
883−unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
1076+unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
884unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1077unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
885 where x = (readV0, v')
1078 where x = (readV0, v')
887−newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
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'
896−--type role Behavior representational
898− = forall p. BehaviorHold !(Hold p a)
899− | BehaviorHoldIdentity !(Hold Identity a)
901− | BehaviorPull !(Pull a)
902− | BehaviorDynIdentity !(Dyn Identity a)
903− | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
905-- ResultM can read behaviors and events
1080-- ResultM can read behaviors and events
906type ResultM = EventM
1081type ResultM = EventM
@@ -909,24 +1084,19 @@ type ResultM = EventM
909unsafeNewIORef :: a -> b -> IORef b
1084unsafeNewIORef :: a -> b -> IORef b
910unsafeNewIORef _ b = unsafePerformIO $ newIORef b
1085unsafeNewIORef _ b = unsafePerformIO $ newIORef b
912−instance Functor Event where
1087+instance HasSpiderTimeline x => Functor (Event x) where
913 fmap f = push $ return . Just . f
1088 fmap f = push $ return . Just . f
915−instance Functor Behavior where
1090+instance Functor (Behavior x) where
916 fmap f = pull . fmap f . readBehaviorTracked
1091 fmap f = pull . fmap f . readBehaviorTracked
918−{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
1093+{-# INLINE push #-}
919−push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
1094+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
920−push f e = EventPush $ Push
1095+push f e = cacheEvent (pushCheap f e)
923− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
925−-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
927−{-# NOINLINE pull #-}
1097+{-# INLINABLE pull #-}
928−pull :: BehaviorM a -> Behavior a
1098+pull :: BehaviorM x a -> Behavior x a
929−pull a = BehaviorPull $ Pull
1099+pull a = behaviorPull $ Pull
930 { pullCompute = a
1100 { pullCompute = a
931 , pullValue = unsafeNewIORef a Nothing
1101 , pullValue = unsafeNewIORef a Nothing
932#ifdef DEBUG_NODEIDS
1102#ifdef DEBUG_NODEIDS
@@ -934,29 +1104,25 @@ pull a = BehaviorPull $ Pull
937−{-# NOINLINE switch #-}
1107+{-# INLINABLE switch #-}
938−switch :: Behavior (Event a) -> Event a
1108+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
939−switch a = EventSwitch $ Switch
1109+switch a = eventSwitch $ Switch
940 { switchParent = a
1110 { switchParent = a
941 , switchSubscribed = unsafeNewIORef a Nothing
1111 , switchSubscribed = unsafeNewIORef a Nothing
944−coincidence :: Event (Event a) -> Event a
1114+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
945−coincidence a = EventCoincidence $ Coincidence
1115+coincidence a = eventCoincidence $ Coincidence
946 { coincidenceParent = a
1116 { coincidenceParent = a
947 , coincidenceSubscribed = unsafeNewIORef a Nothing
1117 , coincidenceSubscribed = unsafeNewIORef a Nothing
950−propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
951−propagateAndUpdateSubscribersRef subscribersRef a = do
952− propagate a subscribersRef
954-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1120-- 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
956run roots after = do
1122run roots after = do
957− tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
1123+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
958− spiderEnv <- SpiderHost ask
1124+ t <- SpiderHost ask
959− result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
1125+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
960 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1126 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
961 occBefore <- liftIO $ do
1127 occBefore <- liftIO $ do
962 occBefore <- readIORef occRef
1128 occBefore <- readIORef occRef
@@ -967,43 +1133,38 @@ run roots after = do
967 return $ Just r
1133 return $ Just r
968 else return Nothing
1134 else return Nothing
969 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1135 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
970− propagateAndUpdateSubscribersRef subscribersRef a
1136+ propagate a subscribersRef
971− delayedRef <- EventM $ asks eventEnvDelayedMerges
1137+ delayedRef <- asksEventEnv eventEnvDelayedMerges
972 let go = do
1138 let go = do
973 delayed <- liftIO $ readIORef delayedRef
1139 delayed <- liftIO $ readIORef delayedRef
974 case IntMap.minViewWithKey delayed of
1140 case IntMap.minViewWithKey delayed of
975 Nothing -> return ()
1141 Nothing -> return ()
976 Just ((currentHeight, cur), future) -> do
1142 Just ((currentHeight, cur), future) -> do
977− tracePropagate $ "Running height " ++ show currentHeight
1143+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
978 putCurrentHeight $ Height currentHeight
1144 putCurrentHeight $ Height currentHeight
979 liftIO $ writeIORef delayedRef $! future
1145 liftIO $ writeIORef delayedRef $! future
980− forM_ cur $ \d -> case d of
1146+ sequence_ cur
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?)
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
995 putCurrentHeight maxBound
1149 putCurrentHeight maxBound
997− tracePropagate "Done running an event frame"
1151+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
998 return result
1152 return result
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?)
1000data SomeClear = forall a. SomeClear (IORef (Maybe a))
1163data SomeClear = forall a. SomeClear (IORef (Maybe a))
1002data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1165data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1004−data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
1167+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1006−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
1008debugFinalize :: Bool
1169debugFinalize :: Bool
1009debugFinalize = False
1170debugFinalize = False
@@ -1022,41 +1183,37 @@ type WeakList a = [Weak a]
1022#ifdef DEBUG
1183#ifdef DEBUG
1023withIncreasedDepth :: CanTrace x m => m a -> m a
1184withIncreasedDepth :: CanTrace x m => m a -> m a
1024withIncreasedDepth a = do
1185withIncreasedDepth a = do
1025− spiderEnv <- askSpiderTimeline
1186+ spiderTimeline <- askSpiderTimelineEnv
1026− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
1187+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1027 result <- a
1188 result <- a
1028− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
1189+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1029 return result
1190 return result
1031withIncreasedDepth :: m a -> m a
1192withIncreasedDepth :: m a -> m a
1032withIncreasedDepth = id
1193withIncreasedDepth = id
1035−type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)
1196+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1037{-# INLINE tracePropagate #-}
1198{-# INLINE tracePropagate #-}
1038−tracePropagate :: (CanTrace x m) => String -> m ()
1199+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1039−tracePropagate = traceWhen debugPropagate
1200+tracePropagate p = traceWhen p debugPropagate
1041−{-# INLINE traceSubscribe #-}
1042−traceSubscribe :: String -> IO ()
1043−traceSubscribe = when debugSubscribe . liftIO . putStrLn
1045{-# INLINE traceInvalidate #-}
1202{-# INLINE traceInvalidate #-}
1046traceInvalidate :: String -> IO ()
1203traceInvalidate :: String -> IO ()
1047traceInvalidate = when debugInvalidate . liftIO . putStrLn
1204traceInvalidate = when debugInvalidate . liftIO . putStrLn
1049{-# INLINE traceWhen #-}
1206{-# INLINE traceWhen #-}
1050−traceWhen :: (CanTrace x m) => Bool -> String -> m ()
1207+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1051−traceWhen b message = traceMWhen b $ return message
1208+traceWhen p b message = traceMWhen p b $ return message
1053{-# INLINE traceMWhen #-}
1210{-# INLINE traceMWhen #-}
1054−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
1211+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1055−traceMWhen b getMessage = when b $ do
1212+traceMWhen _ b getMessage = when b $ do
1056 message <- getMessage
1213 message <- getMessage
1057#ifdef DEBUG
1214#ifdef DEBUG
1058− spiderEnv <- askSpiderTimeline
1215+ spiderTimeline <- askSpiderTimelineEnv
1059− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
1216+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1061 let d = 0
1218 let d = 0
@@ -1065,6 +1222,7 @@ traceMWhen b getMessage = when b $ do
1065whoCreatedIORef :: IORef a -> IO [String]
1222whoCreatedIORef :: IORef a -> IO [String]
1066whoCreatedIORef (IORef a) = whoCreated $! a
1223whoCreatedIORef (IORef a) = whoCreated $! a
1068groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1226groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1069groupByHead = \case
1227groupByHead = \case
1070 [] -> []
1228 [] -> []
@@ -1076,181 +1234,49 @@ groupByHead = \case
1077listsToForest :: Eq a => [[a]] -> Forest a
1235listsToForest :: Eq a => [[a]] -> Forest a
1078listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1236listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
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
1090− Nothing -> return () -- No need to write a Nothing back into the Ref
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)
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
1123− tracePropagate "No subscriber for key"
1126− propagate v $ _fanSubscribedChildren_list subsubs
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
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
1158− Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
1160− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
1161− scheduleClear $ coincidenceSubscribedOccurrence subscribed
1162− propagate a $ coincidenceSubscribedSubscribers subscribed
1163− SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
1165{-# INLINE propagateSubscriberHold #-}
1239{-# 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 ()
1167propagateSubscriberHold h a = do
1241propagateSubscriberHold h a = do
1168− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
1242+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1169 invalidators <- liftIO $ readIORef $ holdInvalidators h
1243 invalidators <- liftIO $ readIORef $ holdInvalidators h
1170 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1244 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1171 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1245 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1172− case {-# SCC "apply" #-} R.apply a v of
1246+ case {-# SCC "apply" #-} apply a v of
1173 Nothing -> return ()
1247 Nothing -> return ()
1174 Just v' -> do
1248 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
1176 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1250 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1177 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1251 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1178 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1252 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1180−data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
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
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
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
1190runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1257runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1192−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
1259+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1193askInvalidator = do
1260askInvalidator = do
1194 (!m, _) <- BehaviorM ask
1261 (!m, _) <- BehaviorM ask
1195 case m of
1262 case m of
1196 Nothing -> return Nothing
1263 Nothing -> return Nothing
1197 Just (!wi, _) -> return $ Just wi
1264 Just (!wi, _) -> return $ Just wi
1199−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
1266+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1200askParentsRef = do
1267askParentsRef = do
1201 (!m, _) <- BehaviorM ask
1268 (!m, _) <- BehaviorM ask
1202 case m of
1269 case m of
1203 Nothing -> return Nothing
1270 Nothing -> return Nothing
1204 Just (_, !p) -> return $ Just p
1271 Just (_, !p) -> return $ Just p
1206−askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1273+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1207askBehaviorHoldInits = do
1274askBehaviorHoldInits = do
1208 (_, !his) <- BehaviorM ask
1275 (_, !his) <- BehaviorM ask
1209 return his
1276 return his
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
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
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
1238− liftIO $ writeIORef (pullValue p) $ Just subscribed
1239− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1241− BehaviorDyn d -> readHoldTracked =<< getDynHold d
1242− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
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) :))
1252{-# INLINE getDynHold #-}
1278{-# 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)
1254getDynHold d = do
1280getDynHold d = do
1255 mh <- liftIO $ readIORef $ unDyn d
1281 mh <- liftIO $ readIORef $ unDyn d
1256 case mh of
1282 case mh of
@@ -1262,72 +1288,30 @@ getDynHold d = do
1262 liftIO $ writeIORef (unDyn d) $ Right h
1288 liftIO $ writeIORef (unDyn d) $ Right h
1263 return h
1289 return h
1265−readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1266−readRootSubscribed = rootSubscribedOccurrence
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
1274−readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1275−readMergeSubscribed subscribed = do
1276− result <- readIORef $ mergeSubscribedOccurrence subscribed
1277− touch $ mergeSubscribedParents subscribed
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
1285−readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1286−readSwitchSubscribed subscribed = do
1287− result <- readIORef $ switchSubscribedOccurrence subscribed
1288− touch $ switchSubscribedOwnInvalidator subscribed
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?
1298-- Always refers to 0
1291-- Always refers to 0
1299{-# NOINLINE zeroRef #-}
1292{-# NOINLINE zeroRef #-}
1300zeroRef :: IORef Height
1293zeroRef :: IORef Height
1301zeroRef = unsafePerformIO $ newIORef zeroHeight
1294zeroRef = unsafePerformIO $ newIORef zeroHeight
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
1310−{-# INLINE debugSubscribe #-}
1311−debugSubscribe :: Bool
1312−debugSubscribe = False
1315type CanSubscribe x m =
1296type CanSubscribe x m =
1316− ( HasSpiderTimeline x m
1297+ ( HasSpiderTimeline x
1317− , HasCurrentHeight m
1298+ , HasCurrentHeight x m
1318− , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1299+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
1319 , Defer SomeClear m -- Wiping out event firings
1300 , Defer SomeClear m -- Wiping out event firings
1320− , Defer SomeAssignment m -- Updating state
1301+ , Defer (SomeAssignment x) m -- Updating state
1321− , Defer SomeResetCoincidence m
1302+ , Defer (SomeResetCoincidence x) m
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)
1325getRootSubscribed k r sub = do
1307getRootSubscribed k r sub = do
1326 mSubscribed <- readIORef $ rootSubscribed r
1308 mSubscribed <- readIORef $ rootSubscribed r
1309+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1327 case DMap.lookup k mSubscribed of
1310 case DMap.lookup k mSubscribed of
1328 Just subscribed -> {-# SCC "hitRoot" #-} do
1311 Just subscribed -> {-# SCC "hitRoot" #-} do
1329 sln <- subscribeRootSubscribed subscribed sub
1312 sln <- subscribeRootSubscribed subscribed sub
1330− return (sln, subscribed)
1314+ return (sln, subscribed, occ)
1331 Nothing -> {-# SCC "missRoot" #-} do
1315 Nothing -> {-# SCC "missRoot" #-} do
1332 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1316 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1333 let !cached = rootSubscribed r
1317 let !cached = rootSubscribed r
@@ -1339,7 +1323,7 @@ getRootSubscribed k r sub = do
1339 let subscribed = RootSubscribed
1323 let subscribed = RootSubscribed
1340 { rootSubscribedKey = k
1324 { rootSubscribedKey = k
1341 , rootSubscribedCachedSubscribed = cached
1325 , rootSubscribedCachedSubscribed = cached
1342− , rootSubscribedOccurrence = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1326+ , rootSubscribedOccurrence = getOcc
1343 , rootSubscribedSubscribers = subs
1327 , rootSubscribedSubscribers = subs
1344 , rootSubscribedUninit = uninit
1328 , rootSubscribedUninit = uninit
1345 , rootSubscribedWeakSelf = weakSelf
1329 , rootSubscribedWeakSelf = weakSelf
@@ -1349,153 +1333,41 @@ getRootSubscribed k r sub = do
1350 writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1334 writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1351 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
1335 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)
1337+ return (sln, subscribed, occ)
1354{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1339{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1355−cleanupRootSubscribed :: RootSubscribed a -> IO ()
1340+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1356cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1341cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1357 rootSubscribedUninit self
1342 rootSubscribedUninit self
1358 modifyIORef' cached $ DMap.delete k
1343 modifyIORef' cached $ DMap.delete k
1360{-# INLINE subscribeRootSubscribed #-}
1345{-# INLINE subscribeRootSubscribed #-}
1361−subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1346+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1362subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1347subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1364−-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1349+{-# INLINABLE getFanSubscribed #-}
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
1397− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1398− liftIO $ writeIORef subscribedRef $! subscribed
1399− liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
1400− return (sln, subscribed)
1402−cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1403−cleanupPushSubscribed self = do
1404− unsubscribe $ pushSubscribedParent self
1405− writeIORef (pushSubscribedCachedSubscribed self) $ Nothing
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
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
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)
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
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)
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
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
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)
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)
1483getFanSubscribed k f sub = do
1351getFanSubscribed k f sub = do
1484 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1352 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1485 case mSubscribed of
1353 case mSubscribed of
1486− Just subscribed -> {-# SCC "hitFan" #-} do
1354+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1487− sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1355+ sln <- subscribeFanSubscribed k subscribed sub
1356+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1488− return (sln, subscribed)
1357+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1489 Nothing -> {-# SCC "missFan" #-} do
1358 Nothing -> {-# SCC "missFan" #-} do
1490 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1359 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1491 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1360 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1492 s <- liftIO $ newSubscriberFan subscribedUnsafe
1361 s <- liftIO $ newSubscriberFan subscribedUnsafe
1493− subscription <- subscribe (fanParent f) s
1362+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1494 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1363 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1495 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1364 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1496 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1365 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1366+ occRef <- liftIO $ newIORef parentOcc
1367+ when (isJust parentOcc) $ scheduleClear occRef
1497 let subscribed = FanSubscribed
1368 let subscribed = FanSubscribed
1498 { fanSubscribedCachedSubscribed = fanSubscribed f
1369 { fanSubscribedCachedSubscribed = fanSubscribed f
1370+ , fanSubscribedOccurrence = occRef
1499 , fanSubscribedParent = subscription
1371 , fanSubscribedParent = subscription
1500 , fanSubscribedSubscribers = subscribersRef
1372 , fanSubscribedSubscribers = subscribersRef
1501#ifdef DEBUG_NODEIDS
1373#ifdef DEBUG_NODEIDS
@@ -1507,9 +1379,9 @@ getFanSubscribed k f sub = do
1507 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1379 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1508 liftIO $ writeIORef subscribedRef $! subscribed
1380 liftIO $ writeIORef subscribedRef $! subscribed
1509 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1381 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1510− return (slnForSub, subscribed)
1382+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1512−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1384+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1513cleanupFanSubscribed (k, subscribed) = do
1385cleanupFanSubscribed (k, subscribed) = do
1514 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1386 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1515 let reducedSubscribers = DMap.delete k subscribers
1387 let reducedSubscribers = DMap.delete k subscribers
@@ -1521,7 +1393,7 @@ cleanupFanSubscribed (k, subscribed) = do
1521 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1393 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1523{-# INLINE subscribeFanSubscribed #-}
1395{-# 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
1525subscribeFanSubscribed k subscribed sub = do
1397subscribeFanSubscribed k subscribed sub = do
1526 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1398 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1527 case DMap.lookup k subscribers of
1399 case DMap.lookup k subscribers of
@@ -1529,18 +1401,19 @@ subscribeFanSubscribed k subscribed sub = do
1529 let !self = (k, subscribed)
1401 let !self = (k, subscribed)
1530 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1402 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1531 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1403 (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
1533 return sln
1405 return sln
1534 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1406 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1536−{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1408+{-# INLINABLE getSwitchSubscribed #-}
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)
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)
1538getSwitchSubscribed s sub = do
1410getSwitchSubscribed s sub = do
1539 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1411 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1540 case mSubscribed of
1412 case mSubscribed of
1541− Just subscribed -> {-# SCC "hitSwitch" #-} do
1413+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1542− sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1414+ sln <- subscribeSwitchSubscribed subscribed sub
1415+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1543− return (sln, subscribed)
1416+ return (sln, subscribed, occ)
1544 Nothing -> {-# SCC "missSwitch" #-} do
1417 Nothing -> {-# SCC "missSwitch" #-} do
1545 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1418 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1546 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1419 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1551,12 +1424,11 @@ getSwitchSubscribed s sub = do
1551 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1424 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1552 holdInits <- getDeferralQueue
1425 holdInits <- getDeferralQueue
1553 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1426 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
1555 subscriptionRef <- liftIO $ newIORef subscription
1429 subscriptionRef <- liftIO $ newIORef subscription
1556− parentOcc <- liftIO $ readEventSubscribed subd
1557 occRef <- liftIO $ newIORef parentOcc
1430 occRef <- liftIO $ newIORef parentOcc
1558 when (isJust parentOcc) $ scheduleClear occRef
1431 when (isJust parentOcc) $ scheduleClear occRef
1559− heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1560 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1432 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1561 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1433 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1562 let !subscribed = SwitchSubscribed
1434 let !subscribed = SwitchSubscribed
@@ -1577,32 +1449,32 @@ getSwitchSubscribed s sub = do
1577 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1449 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1578 liftIO $ writeIORef subscribedRef $! subscribed
1450 liftIO $ writeIORef subscribedRef $! subscribed
1579 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1451 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1580− return (slnForSub, subscribed)
1452+ return (slnForSub, subscribed, parentOcc)
1582−cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1454+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1583cleanupSwitchSubscribed subscribed = do
1455cleanupSwitchSubscribed subscribed = do
1584 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1456 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1585 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1457 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1586 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1458 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1588{-# INLINE subscribeSwitchSubscribed #-}
1460{-# INLINE subscribeSwitchSubscribed #-}
1589−subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1461+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1590subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1462subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1592−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1464+{-# INLINABLE getCoincidenceSubscribed #-}
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)
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)
1594getCoincidenceSubscribed c sub = do
1466getCoincidenceSubscribed c sub = do
1595 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1467 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1596 case mSubscribed of
1468 case mSubscribed of
1597− Just subscribed -> {-# SCC "hitCoincidence" #-} do
1469+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1598− sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1470+ sln <- subscribeCoincidenceSubscribed subscribed sub
1471+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1599− return (sln, subscribed)
1472+ return (sln, subscribed, occ)
1600 Nothing -> {-# SCC "missCoincidence" #-} do
1473 Nothing -> {-# SCC "missCoincidence" #-} do
1601 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1474 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1602 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1475 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1603 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1476 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1604− outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
1477+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1605− outerOcc <- liftIO $ readEventSubscribed outerSubd
1606 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1478 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1607 (occ, height, mInnerSubd) <- case outerOcc of
1479 (occ, height, mInnerSubd) <- case outerOcc of
1608 Nothing -> return (Nothing, outerHeight, Nothing)
1480 Nothing -> return (Nothing, outerHeight, Nothing)
@@ -1632,35 +1504,158 @@ getCoincidenceSubscribed c sub = do
1632 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1504 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1633 liftIO $ writeIORef subscribedRef $! subscribed
1505 liftIO $ writeIORef subscribedRef $! subscribed
1634 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1506 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1635− return (slnForSub, subscribed)
1507+ return (slnForSub, subscribed, occ)
1637−cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1509+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1638cleanupCoincidenceSubscribed subscribed = do
1510cleanupCoincidenceSubscribed subscribed = do
1639 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1511 unsubscribe $ coincidenceSubscribedOuterParent subscribed
1640 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1512 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1642{-# INLINE subscribeCoincidenceSubscribed #-}
1514{-# INLINE subscribeCoincidenceSubscribed #-}
1643−subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1515+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1644subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1516subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1646{-# INLINE merge #-}
1518{-# INLINE merge #-}
1647−merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
1519+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1648−merge m = EventMerge $ Merge
1520+merge d = cacheEvent (mergeCheap d)
1649− { mergeParents = m
1521+
1650− , mergeSubscribed = unsafeNewIORef m Nothing
1522+{-# INLINE [1] mergeCheap #-}
1651− }
1523+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1652−
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
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
1568+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1569+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1572+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1573+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1574+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
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
1583+ , subscriberRecalculateHeight = \new -> do
1584+ modifyIORef' heightBagRef $ heightBagAdd new
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
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)
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
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
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 ()
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)
1653−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1648+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
1655−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1650+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
1657 let f = Fan
1652 let f = Fan
1658 { fanParent = e
1653 { fanParent = e
1659 , fanSubscribed = unsafeNewIORef e Nothing
1654 , fanSubscribed = unsafeNewIORef e Nothing
1661− in EventSelector $ \k -> EventFan k f
1656+ in EventSelector $ \k -> eventFan k f
1663−runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1658+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()
1664runHoldInits holdInitRef mergeInitRef = do
1659runHoldInits holdInitRef mergeInitRef = do
1665 holdInits <- liftIO $ readIORef holdInitRef
1660 holdInits <- liftIO $ readIORef holdInitRef
1666 mergeInits <- liftIO $ readIORef mergeInitRef
1661 mergeInits <- liftIO $ readIORef mergeInitRef
@@ -1668,26 +1663,14 @@ runHoldInits holdInitRef mergeInitRef = do
1668 liftIO $ writeIORef holdInitRef []
1663 liftIO $ writeIORef holdInitRef []
1669 liftIO $ writeIORef mergeInitRef []
1664 liftIO $ writeIORef mergeInitRef []
1670 mapM_ initHold holdInits
1665 mapM_ initHold holdInits
1671− mapM_ initMerge mergeInits
1666+ mapM_ unSomeMergeInit mergeInits
1672 runHoldInits holdInitRef mergeInitRef
1667 runHoldInits holdInitRef mergeInitRef
1674−initHold :: SomeHoldInit -> EventM x ()
1669+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
1675initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1670initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1677−initMerge :: SomeMergeInit -> EventM x ()
1672+newEventEnv :: IO (EventEnv x)
1678−initMerge (SomeMergeInit subscribed changed) = do
1673+newEventEnv = 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)
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
1691 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1674 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1692 holdInitRef <- newIORef []
1675 holdInitRef <- newIORef []
1693 mergeUpdateRef <- newIORef []
1676 mergeUpdateRef <- newIORef []
@@ -1696,50 +1679,48 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1696 toClearRef <- newIORef []
1679 toClearRef <- newIORef []
1697 toClearRootRef <- newIORef []
1680 toClearRootRef <- newIORef []
1698 coincidenceInfosRef <- newIORef []
1681 coincidenceInfosRef <- newIORef []
1699− delayedRef <- liftIO $ newIORef IntMap.empty
1682+ delayedRef <- newIORef IntMap.empty
1700− let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1683+ return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
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
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)
1701 let go = do
1701 let go = do
1702 result <- a
1702 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
1704 return result
1704 return result
1705− result <- runEventM go env
1705+ result <- runEventM go
1706− toClear <- readIORef toClearRef
1706+ toClear <- readIORef $ eventEnvClears env
1707 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1707 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1708− toClearRoot <- readIORef toClearRootRef
1708+ toClearRoot <- readIORef $ eventEnvRootClears env
1709 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1709 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1710− toAssign <- readIORef toAssignRef
1710+ toAssign <- readIORef $ eventEnvAssignments env
1711 toReconnectRef <- newIORef []
1711 toReconnectRef <- newIORef []
1712− coincidenceInfos <- readIORef coincidenceInfosRef
1712+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
1713 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1713 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1714 writeIORef vRef v
1714 writeIORef vRef v
1715 when debugInvalidate $ putStrLn $ "Invalidating Hold"
1715 when debugInvalidate $ putStrLn $ "Invalidating Hold"
1716 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1716 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1717− mergeUpdates <- readIORef mergeUpdateRef
1717+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
1718− writeIORef mergeUpdateRef []
1718+ writeIORef (eventEnvMergeUpdates env) []
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
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
1739 when debugPropagate $ putStrLn "Updating merges"
1719 when debugPropagate $ putStrLn "Updating merges"
1740− mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1720+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
1741 when debugPropagate $ putStrLn "Updating merges done"
1721 when debugPropagate $ putStrLn "Updating merges done"
1742 toReconnect <- readIORef toReconnectRef
1722 toReconnect <- readIORef toReconnectRef
1743 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1724 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1744 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1725 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1745 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1726 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
@@ -1749,12 +1730,12 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1749 wi' <- mkWeakPtrWithDebug i "wi'"
1730 wi' <- mkWeakPtrWithDebug i "wi'"
1750 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
1731 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
1751 writeIORef (switchSubscribedBehaviorParents subscribed) []
1732 writeIORef (switchSubscribedBehaviorParents subscribed) []
1752− writeIORef holdInitRef [] --TODO: Should we reuse this?
1733+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
1753− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1734+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
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
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
1755 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1736 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1756 sub <- newSubscriberSwitch subscribed
1737 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
1759 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1740 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1760 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1741 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1763,9 +1744,9 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1763 _ -> "something else"
1744 _ -> "something else"
1765 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1746 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1766− return $ SomeEventSubscription oldSubscription
1747+ return oldSubscription
1767− forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1748+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
1768− forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1749+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
1769 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1750 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1770 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1751 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1771 parentHeight <- getEventSubscribedHeight subd'
1752 parentHeight <- getEventSubscribedHeight subd'
@@ -1773,13 +1754,12 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1773 when (parentHeight /= myHeight) $ do
1754 when (parentHeight /= myHeight) $ do
1774 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1755 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1775 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1756 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
1778 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1758 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1779 unsubscribe subscription
1759 unsubscribe subscription
1780 mapM_ invalidateCoincidenceHeight mcs
1760 mapM_ invalidateCoincidenceHeight mcs
1781 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1761 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1782− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1762+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
1783 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1763 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1784 height <- calculateSwitchHeight subscribed
1764 height <- calculateSwitchHeight subscribed
1785 updateSwitchHeight height subscribed
1765 updateSwitchHeight height subscribed
@@ -1795,10 +1775,12 @@ zeroHeight = Height 0
1795invalidHeight :: Height
1775invalidHeight :: Height
1796invalidHeight = Height (-1000)
1776invalidHeight = Height (-1000)
1798-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1779-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1799{-# INLINE invalidHeightBeingTraversed #-}
1780{-# INLINE invalidHeightBeingTraversed #-}
1800invalidHeightBeingTraversed :: Height
1781invalidHeightBeingTraversed :: Height
1801invalidHeightBeingTraversed = Height (-1001)
1782invalidHeightBeingTraversed = Height (-1001)
1803{-# INLINE succHeight #-}
1785{-# INLINE succHeight #-}
1804succHeight :: Height -> Height
1786succHeight :: Height -> Height
@@ -1807,121 +1789,14 @@ succHeight h@(Height a) =
1807 then invalidHeight
1789 then invalidHeight
1808 else Height $ succ a
1790 else Height $ succ a
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 ()
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
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
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
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
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
1884−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1792+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1885invalidateCoincidenceHeight subscribed = do
1793invalidateCoincidenceHeight subscribed = do
1886 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1794 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1887 when (oldHeight /= invalidHeight) $ do
1795 when (oldHeight /= invalidHeight) $ do
1888 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
1796 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
1889 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1797 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
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 ()
1924−updateSwitchHeight :: Height -> SwitchSubscribed a -> IO ()
1799+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
1925updateSwitchHeight new subscribed = do
1800updateSwitchHeight new subscribed = do
1926 oldHeight <- readIORef $ switchSubscribedHeight subscribed
1801 oldHeight <- readIORef $ switchSubscribedHeight subscribed
1927 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1802 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
@@ -1929,7 +1804,7 @@ updateSwitchHeight new subscribed = do
1929 writeIORef (switchSubscribedHeight subscribed) $! new
1804 writeIORef (switchSubscribedHeight subscribed) $! new
1930 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1805 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1932−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1807+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1933recalculateCoincidenceHeight subscribed = do
1808recalculateCoincidenceHeight subscribed = do
1934 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1809 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1935 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1810 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
@@ -1938,18 +1813,18 @@ recalculateCoincidenceHeight subscribed = do
1938 writeIORef (coincidenceSubscribedHeight subscribed) $! height
1813 writeIORef (coincidenceSubscribedHeight subscribed) $! height
1939 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1814 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1941−calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1816+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
1942calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1817calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1944−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1819+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
1945calculateCoincidenceHeight subscribed = do
1820calculateCoincidenceHeight subscribed = do
1946 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1821 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1947 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1822 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1948 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1823 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1950−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1825+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
1952−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1827+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
1953invalidate toReconnectRef wis = do
1828invalidate toReconnectRef wis = do
1954 forM_ wis $ \wi -> do
1829 forM_ wis $ \wi -> do
1955 mi <- deRefWeak wi
1830 mi <- deRefWeak wi
@@ -1975,174 +1850,95 @@ invalidate toReconnectRef wis = do
1975-- Reflex integration
1850-- Reflex integration
1976--------------------------------------------------------------------------------
1851--------------------------------------------------------------------------------
1978−-- | The default, global Spider environment
1853+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1979−type Spider = SpiderTimeline Global
1854+-- When we're specializing, we include this from Reflex.Class instead, because
1980−
1855+-- it needs access to these types; when we're not, we want them here, so our
1981−-- | Designates the default, global Spider timeline
1856+-- instance isn't an orphan instance.
1982−data Global
1857+#include "SpiderTimeline.include.hs"
1983−
1858+#include "SpiderTimelineHost.include.hs"
1984−{-# NOINLINE globalSpiderTimeline #-}
1985−globalSpiderTimeline :: SpiderTimeline Global
1986−globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
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 ()])
1995− , _spiderEnv_depth :: !(IORef Int)
1998−type role SpiderTimeline nominal
2000−instance GEq SpiderTimeline where
1861+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2001− a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
1862+unsafeNewSpiderTimelineEnv = do
2002− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimeline can't have two different 'x' arguments
2005−unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)
2006−unsafeNewSpiderTimeline = do
2007− toUnsubscribe <- newIORef []
2008 lock <- newMVar ()
1863 lock <- newMVar ()
2009− cleanups <- newIORef []
1864+ env <- newEventEnv
2010#ifdef DEBUG
1865#ifdef DEBUG
2011 depthRef <- newIORef 0
1866 depthRef <- newIORef 0
2013− return $ SpiderTimeline
1868+ return $ SpiderTimelineEnv
2014− { _spiderEnv_toUnsubscribe = toUnsubscribe
1869+ { _spiderTimeline_lock = lock
2015− , _spiderEnv_lock = lock
1870+ , _spiderTimeline_eventEnv = env
2016− , _spiderEnv_cleanups = cleanups
2017#ifdef DEBUG
1871#ifdef DEBUG
2018− , _spiderEnv_depth = depthRef
1872+ , _spiderTimeline_depth = depthRef
2022−-- | Create a new SpiderTimeline
1876+-- | Create a new SpiderTimelineEnv
2023−newSpiderTimeline :: IO (Some SpiderTimeline)
1877+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2024newSpiderTimeline = withSpiderTimeline (pure . Some.This)
1878newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2026-- | Pass a new timeline to the given function.
1880-- | Pass a new timeline to the given function.
2027−withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r
1881+withSpiderTimeline :: (forall x. SpiderTimelineEnv x -> IO r) -> IO r
2028−withSpiderTimeline k = unsafeNewSpiderTimeline >>= k
1882+withSpiderTimeline k = unsafeNewSpiderTimelineEnv >>= k
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)
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)
1888+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2034−instance R.Reflex (SpiderTimeline x) where
1889+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
1890+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2035− newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1891+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2036− newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event a }
1892+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2037− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
1893+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2038− newtype Incremental (SpiderTimeline x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
1894+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2039 type PullM (SpiderTimeline x) = SpiderPullM x
1895 type PullM (SpiderTimeline x) = SpiderPullM x
2040 type PushM (SpiderTimeline x) = SpiderPushM x
1896 type PushM (SpiderTimeline x) = SpiderPushM x
2041 {-# INLINABLE never #-}
1897 {-# INLINABLE never #-}
2042− never = SpiderEvent EventNever
1898+ never = SpiderEvent eventNever
2043 {-# INLINABLE constant #-}
1899 {-# INLINABLE constant #-}
2044− constant = SpiderBehavior . BehaviorConst
1900+ constant = SpiderBehavior . behaviorConst
2045− {-# INLINABLE push #-}
1901+ {-# INLINE push #-}
2046 push f = SpiderEvent . push (coerce f) . unSpiderEvent
1902 push f = SpiderEvent . push (coerce f) . unSpiderEvent
2047 {-# INLINABLE pull #-}
1903 {-# INLINABLE pull #-}
2048 pull = SpiderBehavior . pull . coerce
1904 pull = SpiderBehavior . pull . coerce
2049 {-# INLINABLE merge #-}
1905 {-# 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))
2051 {-# INLINABLE fan #-}
1907 {-# INLINABLE fan #-}
2052 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1908 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2053 {-# INLINABLE switch #-}
1909 {-# 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
2055 {-# INLINABLE coincidence #-}
1911 {-# 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
2057 {-# INLINABLE current #-}
1913 {-# INLINABLE current #-}
2058− current = SpiderBehavior . current . unSpiderDynamic
1914+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2059 {-# INLINABLE updated #-}
1915 {-# INLINABLE updated #-}
2060− updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
1916+ updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic
2061 {-# INLINABLE unsafeBuildDynamic #-}
1917 {-# 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'
2063 {-# INLINABLE unsafeBuildIncremental #-}
1919 {-# INLINABLE unsafeBuildIncremental #-}
2064− unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1920+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
2065 {-# INLINABLE mergeIncremental #-}
1921 {-# 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
2067 {-# INLINABLE currentIncremental #-}
1923 {-# INLINABLE currentIncremental #-}
2068− currentIncremental = SpiderBehavior . current . unSpiderIncremental
1924+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2069 {-# INLINABLE updatedIncremental #-}
1925 {-# INLINABLE updatedIncremental #-}
2070− updatedIncremental = SpiderEvent . updated . unSpiderIncremental
1926+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2071 {-# INLINABLE incrementalToDynamic #-}
1927 {-# INLINABLE incrementalToDynamic #-}
2072− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
1928+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2073− c <- readBehaviorUntracked $ current i
1929+ c <- readBehaviorUntracked $ dynamicCurrent i
2074− return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'
1930+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2075−
1931+ eventCoercion Coercion = Coercion
2076−instance R.MonadSample (SpiderTimeline x) (EventM x) where
1932+ behaviorCoercion Coercion = Coercion
2077− {-# INLINABLE sample #-}
1933+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2078− sample (SpiderBehavior b) = readBehaviorUntracked b
1934+#endif
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
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
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
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
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
2105−instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where
2106− {-# INLINABLE sample #-}
2107− sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2109−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2110− {-# INLINABLE sample #-}
2111− sample = coerce . readBehaviorTracked . unSpiderBehavior
2113−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2114− {-# INLINABLE sample #-}
2115− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
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
2125−data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
1936+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2126−newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
1938+data SpiderEventHandle x a = SpiderEventHandle
2127−
1939+ { spiderEventHandleSubscription :: EventSubscription x
2128−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
1940+ , spiderEventHandleValue :: IORef (Maybe a)
2129− {-# INLINABLE subscribeEvent #-}
1941+ }
2130− subscribeEvent e = SpiderHostFrame $ do
2131− subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2132− return $ SpiderEventHandle subscription
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
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
2147instance MonadRef (EventM x) where
1943instance MonadRef (EventM x) where
2148 type Ref (EventM x) = Ref IO
1944 type Ref (EventM x) = Ref IO
@@ -2158,7 +1954,7 @@ instance MonadAtomicRef (EventM x) where
2158 atomicModifyRef r f = liftIO $ atomicModifyRef r f
1954 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2160-- | The monad for actions that manipulate a Spider timeline identified by @x@
1956-- | 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)
2163instance Monad (SpiderHost x) where
1959instance Monad (SpiderHost x) where
2164 {-# INLINABLE (>>=) #-}
1960 {-# INLINABLE (>>=) #-}
@@ -2173,11 +1969,11 @@ instance Monad (SpiderHost x) where
2173-- | Run an action affecting the global Spider timeline; this will be guarded by
1969-- | Run an action affecting the global Spider timeline; this will be guarded by
2174-- a mutex for that timeline
1970-- a mutex for that timeline
2175runSpiderHost :: SpiderHost Global a -> IO a
1971runSpiderHost :: SpiderHost Global a -> IO a
2176−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline
1972+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2178-- | Run an action affecting a given Spider timeline; this will be guarded by a
1974-- | Run an action affecting a given Spider timeline; this will be guarded by a
2179-- mutex for that timeline
1975-- mutex for that timeline
2180−runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a
1976+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2181runSpiderHostForTimeline (SpiderHost a) = runReaderT a
1977runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2183newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1979newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
@@ -2192,27 +1988,12 @@ instance Monad (SpiderHostFrame x) where
2192 {-# INLINABLE fail #-}
1988 {-# INLINABLE fail #-}
2193 fail s = SpiderHostFrame $ fail s
1989 fail s = SpiderHostFrame $ fail s
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
2198−addIdentity :: Event a -> Event (Identity a)
2199−--addIdentity = fmap Identity
2200−addIdentity = unsafeCoerce
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
2210−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
1991+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2211newEventWithTriggerIO f = do
1992newEventWithTriggerIO f = do
2212 es <- newFanEventWithTriggerIO $ \Refl -> f
1993 es <- newFanEventWithTriggerIO $ \Refl -> f
2213 return $ select es Refl
1994 return $ select es Refl
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)
2216newFanEventWithTriggerIO f = do
1997newFanEventWithTriggerIO f = do
2217 occRef <- newIORef DMap.empty
1998 occRef <- newIORef DMap.empty
2218 subscribedRef <- newIORef DMap.empty
1999 subscribedRef <- newIORef DMap.empty
@@ -2221,48 +2002,10 @@ newFanEventWithTriggerIO f = do
2221 , rootSubscribed = subscribedRef
2002 , rootSubscribed = subscribedRef
2222 , rootInit = f
2003 , rootInit = f
2224− return $ EventSelector $ \k -> EventRoot k r
2005+ return $ EventSelector $ \k -> eventRoot k r
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
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
2238−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2239− {-# INLINABLE subscribeEvent #-}
2240− subscribeEvent = subscribeEventSpiderHost
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
2247newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2007newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2249−instance R.MonadSample (SpiderTimeline x) (ReadPhase x) where
2250− {-# INLINABLE sample #-}
2251− sample = ReadPhase . R.sample
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
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
2266instance MonadRef (SpiderHost x) where
2009instance MonadRef (SpiderHost x) where
2267 type Ref (SpiderHost x) = Ref IO
2010 type Ref (SpiderHost x) = Ref IO
2268 newRef = SpiderHost . newRef
2011 newRef = SpiderHost . newRef
@@ -2281,9 +2024,6 @@ instance MonadRef (SpiderHostFrame x) where
2281instance MonadAtomicRef (SpiderHostFrame x) where
2024instance MonadAtomicRef (SpiderHostFrame x) where
2282 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2025 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2284−--------------------------------------------------------------------------------
2027+instance PrimMonad (SpiderHostFrame x) where
2285−-- Deprecated items
2028+ type PrimState (SpiderHostFrame x) = PrimState IO
2286−--------------------------------------------------------------------------------
2029+ primitive = SpiderHostFrame . EventM . primitive
2288−{-# DEPRECATED SpiderEnv "Use 'SpiderTimeline' instead" #-}
2289−type SpiderEnv = SpiderTimeline