@@ -0,0 +1,2045 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE LambdaCase #-}
11+{-# LANGUAGE MagicHash #-}
12+{-# LANGUAGE MultiParamTypeClasses #-}
13+{-# LANGUAGE MultiWayIf #-}
14+{-# LANGUAGE RankNTypes #-}
15+{-# LANGUAGE RoleAnnotations #-}
16+{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TypeOperators #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+#ifdef USE_REFLEX_OPTIMIZER
21+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22+#endif
23+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
24+{-# OPTIONS_GHC -fno-warn-orphans #-}
25+#endif
26+-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
27+-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
28+module Reflex.Spider.Internal where
29+
30+import Control.Applicative
31+import Control.Concurrent
32+import Control.Exception
33+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
34+import Control.Monad.Exception
35+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
36+import Control.Monad.Primitive
37+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
38+import Control.Monad.Ref
39+import Data.Align
40+import Data.Coerce
41+import Data.Dependent.Map (DMap, DSum (..))
42+import qualified Data.Dependent.Map as DMap
43+import Data.Foldable hiding (concat, elem, sequence_)
44+import Data.Function
45+import Data.Functor.Constant
46+import Data.Functor.Misc
47+import Data.Functor.Product
48+import Data.GADT.Compare
49+import Data.IntMap.Strict (IntMap)
50+import qualified Data.IntMap.Strict as IntMap
51+import Data.IORef
52+import Data.List hiding (foldl')
53+import Data.Maybe
54+import Data.Monoid ((<>))
55+import Data.Proxy
56+import Data.These
57+import Data.Traversable
58+import Data.Word
59+import GHC.Exts
60+import GHC.IORef (IORef (..))
61+import GHC.Stack
62+import Reflex.FunctorMaybe
63+import System.IO.Unsafe
64+import System.Mem.Weak
65+import Unsafe.Coerce
66+
67+#ifdef DEBUG_CYCLES
68+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
69+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
70+import qualified Data.List.NonEmpty as NonEmpty
71+import Data.Monoid (mempty)
72+import Data.Tree (Forest, Tree (..), drawForest)
73+#endif
74+
75+import Data.WeakBag (WeakBag, WeakBagTicket)
76+import qualified Data.WeakBag as WeakBag
77+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78+import Data.Reflection
79+import Data.Some (Some)
80+import qualified Data.Some as Some
81+import Data.Type.Coercion
82+import qualified Reflex.Class
83+import qualified Reflex.Class as R
84+import qualified Reflex.Host.Class
85+#endif
86+import Reflex.Patch
87+
88+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
89+import Prelude hiding (any, concat, mapM, mapM_, sequence)
90+
91+debugPropagate :: Bool
92+
93+debugInvalidateHeight :: Bool
94+
95+debugInvalidate :: Bool
96+
97+#ifdef DEBUG
98+
99+#define DEBUG_NODEIDS
100+
101+debugPropagate = True
102+
103+debugInvalidateHeight = False
104+
105+debugInvalidate = True
106+
107+class HasNodeId a where
108+ getNodeId :: a -> Int
109+
110+instance HasNodeId (Hold x p a) where
111+ getNodeId = holdNodeId
112+
113+instance HasNodeId (PushSubscribed x a b) where
114+ getNodeId = pushSubscribedNodeId
115+
116+instance HasNodeId (SwitchSubscribed x a) where
117+ getNodeId = switchSubscribedNodeId
118+
119+instance HasNodeId (FanSubscribed x a) where
120+ getNodeId = fanSubscribedNodeId
121+
122+instance HasNodeId (CoincidenceSubscribed x a) where
123+ getNodeId = coincidenceSubscribedNodeId
124+
125+instance HasNodeId (RootSubscribed x a) where
126+ getNodeId = rootSubscribedNodeId
127+
128+instance HasNodeId (Pull x a) where
129+ getNodeId = pullNodeId
130+
131+{-# INLINE showNodeId #-}
132+showNodeId :: HasNodeId a => a -> String
133+showNodeId = ("#"<>) . show . getNodeId
134+
135+showSubscriberType :: Subscriber x a -> String
136+showSubscriberType = \case
137+ SubscriberPush _ _ -> "SubscriberPush"
138+ SubscriberMerge _ _ -> "SubscriberMerge"
139+ SubscriberFan _ -> "SubscriberFan"
140+ SubscriberMergeChange _ -> "SubscriberMergeChange"
141+ SubscriberHold _ -> "SubscriberHold"
142+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
143+ SubscriberSwitch _ -> "SubscriberSwitch"
144+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
145+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
146+ SubscriberHandle -> "SubscriberHandle"
147+
148+showEventType :: Event x a -> String
149+showEventType = \case
150+ EventRoot _ _ -> "EventRoot"
151+ EventNever -> "EventNever"
152+ EventPush _ -> "EventPush"
153+ EventMerge _ -> "EventMerge"
154+ EventFan _ _ -> "EventFan"
155+ EventSwitch _ -> "EventSwitch"
156+ EventCoincidence _ -> "EventCoincidence"
157+ EventHold _ -> "EventHold"
158+ EventDyn _ -> "EventDyn"
159+ EventHoldIdentity _ -> "EventHoldIdentity"
160+ EventDynIdentity _ -> "EventDynIdentity"
161+
162+#else
163+
164+debugPropagate = False
165+
166+debugInvalidateHeight = False
167+
168+debugInvalidate = False
169+
170+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
171+{-# INLINE showNodeId #-}
172+showNodeId :: a -> String
173+showNodeId _ = ""
174+
175+#endif
176+
177+#ifdef DEBUG_NODEIDS
178+{-# NOINLINE nextNodeIdRef #-}
179+nextNodeIdRef :: IORef Int
180+nextNodeIdRef = unsafePerformIO $ newIORef 1
181+
182+newNodeId :: IO Int
183+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
184+
185+{-# NOINLINE unsafeNodeId #-}
186+unsafeNodeId :: a -> Int
187+unsafeNodeId a = unsafePerformIO $ do
188+ touch a
189+ newNodeId
190+#endif
191+
192+--------------------------------------------------------------------------------
193+-- Event
194+--------------------------------------------------------------------------------
195+
196+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
197+
198+{-# INLINE subscribeAndRead #-}
199+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
200+subscribeAndRead = unEvent
201+
202+{-# RULES
203+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
204+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
205+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
206+ #-}
207+
208+-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
209+-- caching; if the computation function is very cheap, this is (much) more
210+-- efficient than 'push'
211+{-# NOINLINE pushCheap #-}
212+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
213+pushCheap f e = Event $ \sub -> do
214+ (subscription, occ) <- subscribeAndRead e $ sub
215+ { subscriberPropagate = \a -> do
216+ mb <- runComputeM $ f a
217+ mapM_ (subscriberPropagate sub) mb
218+ }
219+ occ' <- join <$> mapM (runComputeM . f) occ
220+ return (subscription, occ')
221+
222+data CacheSubscribed x a
223+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))
224+ , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))
225+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
226+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
227+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
228+ }
229+
230+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
231+-- repeatedly
232+--
233+--TODO: Try a caching strategy where we subscribe directly to the parent when
234+--there's only one subscriber, and then build our own WeakBag only when a second
235+--subscriber joins
236+{-# NOINLINE cacheEvent #-}
237+cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
238+cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
239+ let !mSubscribedRef = unsafeNewIORef e Nothing
240+ mSubscribed <- liftIO $ readIORef mSubscribedRef
241+ case mSubscribed of
242+ Just subscribed -> liftIO $ do
243+ ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
244+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
245+ let es = EventSubscribed
246+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
247+ , eventSubscribedRetained = toAny subscribed
248+ }
249+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
250+ Nothing -> do
251+ weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
252+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
253+ occRef <- liftIO $ newIORef undefined
254+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
255+ { subscriberPropagate = \a -> do
256+ liftIO $ writeIORef occRef $ Just a
257+ scheduleClear occRef
258+ propagate a subscribers
259+ , subscriberInvalidateHeight = \old -> do
260+ WeakBag.traverse subscribers $ invalidateSubscriberHeight old
261+ , subscriberRecalculateHeight = \new -> do
262+ WeakBag.traverse subscribers $ recalculateSubscriberHeight new
263+ }
264+ liftIO $ writeIORef occRef occ
265+ when (isJust occ) $ scheduleClear occRef
266+ let !subscribed = CacheSubscribed
267+ { _cacheSubscribed_subscribers = subscribers
268+ , _cacheSubscribed_weakSelf = weakSelf
269+ , _cacheSubscribed_parent = parentSub
270+ , _cacheSubscribed_cached = mSubscribedRef
271+ , _cacheSubscribed_occurrence = occRef
272+ }
273+ liftIO $ writeIORef mSubscribedRef $ Just subscribed
274+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
275+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)
276+
277+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
278+cleanupCacheSubscribed self = do
279+ unsubscribe $ _cacheSubscribed_parent self
280+ writeIORef (_cacheSubscribed_cached self) Nothing
281+
282+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
283+subscribe e s = fst <$> subscribeAndRead e s
284+
285+{-# INLINE wrap #-}
286+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
287+wrap tag getSpecificSubscribed sub = do
288+ (sln, subd, occ) <- getSpecificSubscribed sub
289+ let es = tag subd
290+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
291+
292+eventRoot :: GCompare k => k a -> Root x k -> Event x a
293+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
294+
295+eventNever :: Event x a
296+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
297+
298+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
299+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
300+
301+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
302+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
303+
304+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
305+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
306+
307+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
308+eventHold !h = Event $ subscribeHoldEvent h
309+
310+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
311+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
312+
313+{-# INLINE subscribeCoincidenceInner #-}
314+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)
315+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
316+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
317+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
318+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
319+ let height = max innerHeight outerHeight
320+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
321+ return (innerOcc, height, innerSubd)
322+
323+--------------------------------------------------------------------------------
324+-- Subscriber
325+--------------------------------------------------------------------------------
326+
327+data Subscriber x a = Subscriber
328+ { subscriberPropagate :: !(a -> EventM x ())
329+ , subscriberInvalidateHeight :: !(Height -> IO ())
330+ , subscriberRecalculateHeight :: !(Height -> IO ())
331+ }
332+
333+--TODO: Move this comment to WeakBag
334+-- These function are constructor functions that are marked NOINLINE so they are
335+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
336+-- so any weak references that are attached to the constructors will have their
337+-- finalizer run. Using the opaque constructor, does not see the
338+-- constructor application, so it behaves like an IORef and cannot be fused away.
339+--
340+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
341+-- the weak pointer to it in some cases.
342+
343+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
344+newSubscriberHold h = return $ Subscriber
345+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
346+ , subscriberInvalidateHeight = \_ -> return ()
347+ , subscriberRecalculateHeight = \_ -> return ()
348+ }
349+
350+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
351+newSubscriberFan subscribed = return $ Subscriber
352+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
353+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
354+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
355+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
356+ scheduleClear $ fanSubscribedOccurrence subscribed
357+ let f _ (Pair (Identity v) subsubs) = do
358+ propagate v $ _fanSubscribedChildren_list subsubs
359+ return $ Constant ()
360+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
361+ return ()
362+ , subscriberInvalidateHeight = \old -> do
363+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
364+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
365+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
366+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
367+ , subscriberRecalculateHeight = \new -> do
368+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
369+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
370+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
371+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
372+ }
373+
374+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
375+newSubscriberSwitch subscribed = return $ Subscriber
376+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
377+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
378+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
379+ scheduleClear $ switchSubscribedOccurrence subscribed
380+ propagate a $ switchSubscribedSubscribers subscribed
381+ , subscriberInvalidateHeight = \_ -> do
382+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
383+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
384+ when (oldHeight /= invalidHeight) $ do
385+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
386+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
387+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
388+ , subscriberRecalculateHeight = \new -> do
389+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
390+ updateSwitchHeight new subscribed
391+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
392+ }
393+
394+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
395+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
396+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
397+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
398+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
399+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
400+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
401+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
402+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
403+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
404+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
405+ case occ of
406+ Nothing -> do
407+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
408+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
409+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
410+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
411+ Just o -> do -- Since it's already firing, no need to adjust height
412+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
413+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
414+ propagate o $ coincidenceSubscribedSubscribers subscribed
415+ , subscriberInvalidateHeight = \_ -> do
416+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
417+ invalidateCoincidenceHeight subscribed
418+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
419+ , subscriberRecalculateHeight = \_ -> do
420+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
421+ recalculateCoincidenceHeight subscribed
422+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
423+ }
424+
425+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
426+newSubscriberCoincidenceInner subscribed = return $ Subscriber
427+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
428+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
429+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
430+ case occ of
431+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
432+ Nothing -> do
433+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
434+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
435+ propagate a $ coincidenceSubscribedSubscribers subscribed
436+ , subscriberInvalidateHeight = \_ -> do
437+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
438+ invalidateCoincidenceHeight subscribed
439+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
440+ , subscriberRecalculateHeight = \_ -> do
441+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
442+ recalculateCoincidenceHeight subscribed
443+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
444+ }
445+
446+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
447+invalidateSubscriberHeight = flip subscriberInvalidateHeight
448+
449+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
450+recalculateSubscriberHeight = flip subscriberRecalculateHeight
451+
452+-- | Propagate everything at the current height
453+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
454+propagate a subscribers = withIncreasedDepth $ do
455+ -- 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
456+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
457+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
458+
459+--------------------------------------------------------------------------------
460+-- EventSubscribed
461+--------------------------------------------------------------------------------
462+
463+toAny :: a -> Any
464+toAny = unsafeCoerce
465+
466+data EventSubscribed x = EventSubscribed
467+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
468+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
469+#ifdef DEBUG_CYCLES
470+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
471+ , eventSubscribedHasOwnHeightRef :: !Bool
472+ , eventSubscribedWhoCreated :: !(IO [String])
473+#endif
474+ }
475+
476+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
477+eventSubscribedRoot !r = EventSubscribed
478+ { eventSubscribedHeightRef = zeroRef
479+ , eventSubscribedRetained = toAny r
480+#ifdef DEBUG_CYCLES
481+ , eventSubscribedGetParents = return []
482+ , eventSubscribedHasOwnHeightRef = False
483+ , eventSubscribedWhoCreated = return ["root"]
484+#endif
485+ }
486+
487+eventSubscribedNever :: EventSubscribed x
488+eventSubscribedNever = EventSubscribed
489+ { eventSubscribedHeightRef = zeroRef
490+ , eventSubscribedRetained = toAny ()
491+#ifdef DEBUG_CYCLES
492+ , eventSubscribedGetParents = return []
493+ , eventSubscribedHasOwnHeightRef = False
494+ , eventSubscribedWhoCreated = return ["never"]
495+#endif
496+ }
497+
498+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
499+eventSubscribedFan !subscribed = EventSubscribed
500+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
501+ , eventSubscribedRetained = toAny subscribed
502+#ifdef DEBUG_CYCLES
503+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
504+ , eventSubscribedHasOwnHeightRef = False
505+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
506+#endif
507+ }
508+
509+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
510+eventSubscribedSwitch !subscribed = EventSubscribed
511+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
512+ , eventSubscribedRetained = toAny subscribed
513+#ifdef DEBUG_CYCLES
514+ , eventSubscribedGetParents = do
515+ s <- readIORef $ switchSubscribedCurrentParent subscribed
516+ return [Some.This $ _eventSubscription_subscribed s]
517+ , eventSubscribedHasOwnHeightRef = True
518+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
519+#endif
520+ }
521+
522+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
523+eventSubscribedCoincidence !subscribed = EventSubscribed
524+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
525+ , eventSubscribedRetained = toAny subscribed
526+#ifdef DEBUG_CYCLES
527+ , eventSubscribedGetParents = do
528+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
529+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
530+ innerParents = maybeToList $ fmap Some.This innerSubscription
531+ return $ outerParent : innerParents
532+ , eventSubscribedHasOwnHeightRef = True
533+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
534+#endif
535+ }
536+
537+getEventSubscribedHeight :: EventSubscribed x -> IO Height
538+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
539+
540+#ifdef DEBUG_CYCLES
541+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
542+whoCreatedEventSubscribed = eventSubscribedWhoCreated
543+
544+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
545+walkInvalidHeightParents s0 = do
546+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
547+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
548+ when (h == invalidHeight) $ do
549+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
550+ modify (Some.This s :)
551+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
552+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
553+ return subscribers
554+#endif
555+
556+{-# INLINE subscribeHoldEvent #-}
557+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
558+subscribeHoldEvent = subscribeAndRead . holdEvent
559+
560+--------------------------------------------------------------------------------
561+-- EventSubscription
562+--------------------------------------------------------------------------------
563+
564+data EventSubscription x = EventSubscription
565+ { _eventSubscription_unsubscribe :: !(IO ())
566+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
567+ }
568+
569+unsubscribe :: EventSubscription x -> IO ()
570+unsubscribe (EventSubscription u _) = u
571+
572+--------------------------------------------------------------------------------
573+-- Behavior
574+--------------------------------------------------------------------------------
575+
576+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
577+
578+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
579+behaviorHold !h = Behavior $ readHoldTracked h
580+
581+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
582+behaviorHoldIdentity = behaviorHold
583+
584+behaviorConst :: a -> Behavior x a
585+behaviorConst !a = Behavior $ return a
586+
587+behaviorPull :: Pull x a -> Behavior x a
588+behaviorPull !p = Behavior $ do
589+ val <- liftIO $ readIORef $ pullValue p
590+ case val of
591+ Just subscribed -> do
592+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
593+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
594+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
595+ return $ pullSubscribedValue subscribed
596+ Nothing -> do
597+ i <- liftIO $ newInvalidatorPull p
598+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
599+ parentsRef <- liftIO $ newIORef []
600+ holdInits <- askBehaviorHoldInits
601+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
602+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
603+ parents <- liftIO $ readIORef parentsRef
604+ let subscribed = PullSubscribed
605+ { pullSubscribedValue = a
606+ , pullSubscribedInvalidators = invsRef
607+ , pullSubscribedOwnInvalidator = i
608+ , pullSubscribedParents = parents
609+ }
610+ liftIO $ writeIORef (pullValue p) $ Just subscribed
611+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
612+ return a
613+
614+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
615+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
616+
617+{-# INLINE readHoldTracked #-}
618+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
619+readHoldTracked h = do
620+ result <- liftIO $ readIORef $ holdValue h
621+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
622+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
623+ return result
624+
625+{-# INLINABLE readBehaviorUntracked #-}
626+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
627+readBehaviorUntracked b = do
628+ holdInits <- getDeferralQueue
629+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
630+
631+--------------------------------------------------------------------------------
632+-- Dynamic
633+--------------------------------------------------------------------------------
634+
635+data Dynamic x p = Dynamic
636+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
637+ , dynamicUpdated :: !(Event x p)
638+ }
639+
640+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
641+dynamicHold !h = Dynamic
642+ { dynamicCurrent = behaviorHold h
643+ , dynamicUpdated = eventHold h
644+ }
645+
646+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
647+dynamicHoldIdentity = dynamicHold
648+
649+dynamicConst :: PatchTarget p -> Dynamic x p
650+dynamicConst !a = Dynamic
651+ { dynamicCurrent = behaviorConst a
652+ , dynamicUpdated = eventNever
653+ }
654+
655+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
656+dynamicDyn !d = Dynamic
657+ { dynamicCurrent = behaviorDyn d
658+ , dynamicUpdated = eventDyn d
659+ }
660+
661+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
662+dynamicDynIdentity = dynamicDyn
663+
664+--------------------------------------------------------------------------------
665+-- Combinators
666+--------------------------------------------------------------------------------
667+
668+--TODO: Figure out why certain things are not 'representational', then make them
669+--representational so we can use coerce
670+
671+--type role Hold representational
672+data Hold x p
673+ = Hold { holdValue :: !(IORef (PatchTarget p))
674+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
675+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
676+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
677+#ifdef DEBUG_NODEIDS
678+ , holdNodeId :: Int
679+#endif
680+ }
681+
682+data Global
683+
684+{-# NOINLINE globalSpiderTimelineEnv #-}
685+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
686+!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
687+
688+-- | Stores all global data relevant to a particular Spider timeline; only one
689+-- value should exist for each type @x@
690+data SpiderTimelineEnv x = SpiderTimelineEnv
691+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
692+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
693+#ifdef DEBUG
694+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
695+#endif
696+ }
697+type role SpiderTimelineEnv nominal
698+
699+instance GEq SpiderTimelineEnv where
700+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
701+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
702+ else Nothing
703+
704+data EventEnv x
705+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
706+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
707+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
708+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
709+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
710+ , eventEnvRootClears :: !(IORef [SomeRootClear])
711+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
712+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
713+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
714+ }
715+
716+{-# INLINE runEventM #-}
717+runEventM :: EventM x a -> IO a
718+runEventM = unEventM
719+
720+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
721+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
722+
723+class MonadIO m => Defer a m where
724+ getDeferralQueue :: m (IORef [a])
725+
726+{-# INLINE defer #-}
727+defer :: Defer a m => a -> m ()
728+defer a = do
729+ q <- getDeferralQueue
730+ liftIO $ modifyIORef' q (a:)
731+
732+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
733+ {-# INLINE getDeferralQueue #-}
734+ getDeferralQueue = asksEventEnv eventEnvAssignments
735+
736+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
737+ {-# INLINE getDeferralQueue #-}
738+ getDeferralQueue = asksEventEnv eventEnvHoldInits
739+
740+instance Defer (SomeHoldInit x) (BehaviorM x) where
741+ {-# INLINE getDeferralQueue #-}
742+ getDeferralQueue = BehaviorM $ asks snd
743+
744+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
745+ {-# INLINE getDeferralQueue #-}
746+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
747+
748+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
749+ {-# INLINE getDeferralQueue #-}
750+ getDeferralQueue = asksEventEnv eventEnvMergeInits
751+
752+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
753+ getCurrentHeight :: m Height
754+ scheduleMerge :: Height -> EventM x () -> m ()
755+
756+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
757+ {-# INLINE getCurrentHeight #-}
758+ getCurrentHeight = do
759+ heightRef <- asksEventEnv eventEnvCurrentHeight
760+ liftIO $ readIORef heightRef
761+ {-# INLINE scheduleMerge #-}
762+ scheduleMerge height subscribed = do
763+ delayedRef <- asksEventEnv eventEnvDelayedMerges
764+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
765+
766+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
767+class x ~ Global => HasSpiderTimeline x where
768+#else
769+class HasSpiderTimeline x where
770+#endif
771+ -- | Retrieve the current SpiderTimelineEnv
772+ spiderTimeline :: SpiderTimelineEnv x
773+
774+instance HasSpiderTimeline Global where
775+ spiderTimeline = globalSpiderTimelineEnv
776+
777+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
778+putCurrentHeight h = do
779+ heightRef <- asksEventEnv eventEnvCurrentHeight
780+ liftIO $ writeIORef heightRef $! h
781+
782+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
783+ {-# INLINE getDeferralQueue #-}
784+ getDeferralQueue = asksEventEnv eventEnvClears
785+
786+{-# INLINE scheduleClear #-}
787+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
788+scheduleClear r = defer $ SomeClear r
789+
790+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
791+ {-# INLINE getDeferralQueue #-}
792+ getDeferralQueue = asksEventEnv eventEnvRootClears
793+
794+{-# INLINE scheduleRootClear #-}
795+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
796+scheduleRootClear r = defer $ SomeRootClear r
797+
798+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
799+ {-# INLINE getDeferralQueue #-}
800+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
801+
802+-- Note: hold cannot examine its event until after the phase is over
803+{-# INLINE [1] hold #-}
804+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
805+hold v0 e = do
806+ valRef <- liftIO $ newIORef v0
807+ invsRef <- liftIO $ newIORef []
808+ parentRef <- liftIO $ newIORef Nothing
809+#ifdef DEBUG_NODEIDS
810+ nodeId <- liftIO newNodeId
811+#endif
812+ let h = Hold
813+ { holdValue = valRef
814+ , holdInvalidators = invsRef
815+ , holdEvent = e
816+ , holdParent = parentRef
817+#ifdef DEBUG_NODEIDS
818+ , holdNodeId = nodeId
819+#endif
820+ }
821+ defer $ SomeHoldInit h
822+ return h
823+
824+{-# INLINE getHoldEventSubscription #-}
825+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)
826+getHoldEventSubscription h = do
827+ ep <- liftIO $ readIORef $ holdParent h
828+ case ep of
829+ Just subd -> return subd
830+ Nothing -> do
831+ let e = holdEvent h
832+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
833+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
834+ liftIO $ writeIORef subscriptionRef $! subscription
835+ case occ of
836+ Nothing -> return ()
837+ Just o -> do
838+ old <- liftIO $ readIORef $ holdValue h
839+ case apply o old of
840+ Nothing -> return ()
841+ Just new -> do
842+ -- Need to evaluate these so that we don't retain the Hold itself
843+ v <- liftIO $ evaluate $ holdValue h
844+ i <- liftIO $ evaluate $ holdInvalidators h
845+ defer $ SomeAssignment v i new
846+ liftIO $ writeIORef (holdParent h) $ Just subscription
847+ return subscription
848+
849+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
850+
851+--type role BehaviorM representational
852+-- BehaviorM can sample behaviors
853+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
854+
855+instance Monad (BehaviorM x) where
856+ {-# INLINE (>>=) #-}
857+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
858+ {-# INLINE (>>) #-}
859+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
860+ {-# INLINE return #-}
861+ return x = BehaviorM $ return x
862+ {-# INLINE fail #-}
863+ fail s = BehaviorM $ fail s
864+
865+data BehaviorSubscribed x a
866+ = forall p. BehaviorSubscribedHold (Hold x p)
867+ | BehaviorSubscribedPull (PullSubscribed x a)
868+
869+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
870+
871+--type role PullSubscribed representational
872+data PullSubscribed x a
873+ = PullSubscribed { pullSubscribedValue :: !a
874+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
875+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
876+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
877+ }
878+
879+--type role Pull representational
880+data Pull x a
881+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
882+ , pullCompute :: !(BehaviorM x a)
883+#ifdef DEBUG_NODEIDS
884+ , pullNodeId :: Int
885+#endif
886+ }
887+
888+data Invalidator x
889+ = forall a. InvalidatorPull (Pull x a)
890+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
891+
892+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
893+ { rootSubscribedKey :: !(k a)
894+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
895+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
896+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
897+ , rootSubscribedUninit :: IO ()
898+ , 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?
899+#ifdef DEBUG_NODEIDS
900+ , rootSubscribedNodeId :: Int
901+#endif
902+ }
903+
904+data Root x (k :: * -> *)
905+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
906+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
907+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
908+ }
909+
910+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
911+
912+data SomeMergeUpdate x = SomeMergeUpdate
913+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
914+ , _someMergeUpdate_invalidateHeight :: !(IO ())
915+ , _someMergeUpdate_recalculateHeight :: !(IO ())
916+ }
917+
918+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
919+
920+-- EventM can do everything BehaviorM can, plus create holds
921+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
922+
923+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
924+
925+instance Defer (SomeHoldInit x) (ComputeM x) where
926+ getDeferralQueue = ComputeM ask
927+
928+{-# INLINABLE runComputeM #-}
929+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
930+runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
931+
932+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
933+
934+data HeightBag = HeightBag
935+ { _heightBag_size :: {-# UNPACK #-} !Int
936+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
937+ }
938+ deriving (Show, Read, Eq, Ord)
939+
940+heightBagEmpty :: HeightBag
941+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
942+
943+heightBagSize :: HeightBag -> Int
944+heightBagSize = _heightBag_size
945+
946+heightBagFromList :: [Height] -> HeightBag
947+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
948+
949+heightBagAdd :: Height -> HeightBag -> HeightBag
950+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
951+
952+heightBagRemove :: Height -> HeightBag -> HeightBag
953+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
954+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
955+ Just old -> HeightBag (pred s) $ case old of
956+ 0 -> IntMap.delete h c
957+ _ -> IntMap.insert h (pred old) c
958+
959+heightBagMax :: HeightBag -> Height
960+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
961+ Just ((h, _), _) -> Height h
962+ Nothing -> zeroHeight
963+
964+heightBagVerify :: HeightBag -> HeightBag
965+#ifdef DEBUG
966+heightBagVerify b@(HeightBag s c) = if
967+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
968+ -> error $ "heightBagVerify: size doesn't match: " <> show b
969+ | unHeight invalidHeight `IntMap.member` c
970+ -> error $ "heightBagVerify: contains invalid height: " <> show b
971+ | otherwise -> b
972+#else
973+heightBagVerify = id
974+#endif
975+
976+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
977+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
978+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
979+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
980+ }
981+
982+data FanSubscribed (x :: *) k
983+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
984+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
985+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
986+ , fanSubscribedParent :: !(EventSubscription x)
987+#ifdef DEBUG_NODEIDS
988+ , fanSubscribedNodeId :: Int
989+#endif
990+ }
991+
992+data Fan x k
993+ = Fan { fanParent :: !(Event x (DMap k Identity))
994+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
995+ }
996+
997+data SwitchSubscribed x a
998+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
999+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1000+ , switchSubscribedHeight :: !(IORef Height)
1001+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1002+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1003+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1004+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1005+ , switchSubscribedParent :: !(Behavior x (Event x a))
1006+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1007+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1008+#ifdef DEBUG_NODEIDS
1009+ , switchSubscribedNodeId :: Int
1010+#endif
1011+ }
1012+
1013+data Switch x a
1014+ = Switch { switchParent :: !(Behavior x (Event x a))
1015+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1016+ }
1017+
1018+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1019+data CoincidenceSubscribed x a
1020+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1021+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1022+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1023+ , coincidenceSubscribedHeight :: !(IORef Height)
1024+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1025+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1026+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1027+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1028+#ifdef DEBUG_NODEIDS
1029+ , coincidenceSubscribedNodeId :: Int
1030+#endif
1031+ }
1032+
1033+data Coincidence x a
1034+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1035+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1036+ }
1037+
1038+{-# NOINLINE newInvalidatorSwitch #-}
1039+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1040+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1041+
1042+{-# NOINLINE newInvalidatorPull #-}
1043+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1044+newInvalidatorPull p = return $! InvalidatorPull p
1045+
1046+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1047+ fmapMaybe f = push $ return . f
1048+
1049+instance HasSpiderTimeline x => Align (Event x) where
1050+ nil = eventNever
1051+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1052+
1053+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1054+
1055+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1056+newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1057+
1058+--TODO: Avoid the duplication between this and R.zipDynWith
1059+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1060+zipDynWith f da db =
1061+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1062+ ec = flip push eab $ \o -> do
1063+ (a, b) <- case o of
1064+ This (Identity a) -> do
1065+ b <- readBehaviorUntracked $ dynamicCurrent db
1066+ return (a, b)
1067+ That (Identity b) -> do
1068+ a <- readBehaviorUntracked $ dynamicCurrent da
1069+ return (a, b)
1070+ These (Identity a) (Identity b) -> return (a, b)
1071+ return $ Just $ Identity $ f a b
1072+ in dynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1073+
1074+unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1075+unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1076+ where x = (readV0, v')
1077+
1078+-- ResultM can read behaviors and events
1079+type ResultM = EventM
1080+
1081+{-# NOINLINE unsafeNewIORef #-}
1082+unsafeNewIORef :: a -> b -> IORef b
1083+unsafeNewIORef _ b = unsafePerformIO $ newIORef b
1084+
1085+instance HasSpiderTimeline x => Functor (Event x) where
1086+ fmap f = push $ return . Just . f
1087+
1088+instance Functor (Behavior x) where
1089+ fmap f = pull . fmap f . readBehaviorTracked
1090+
1091+{-# INLINE push #-}
1092+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1093+push f e = cacheEvent (pushCheap f e)
1094+
1095+{-# INLINABLE pull #-}
1096+pull :: BehaviorM x a -> Behavior x a
1097+pull a = behaviorPull $ Pull
1098+ { pullCompute = a
1099+ , pullValue = unsafeNewIORef a Nothing
1100+#ifdef DEBUG_NODEIDS
1101+ , pullNodeId = unsafeNodeId a
1102+#endif
1103+ }
1104+
1105+{-# INLINABLE switch #-}
1106+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1107+switch a = eventSwitch $ Switch
1108+ { switchParent = a
1109+ , switchSubscribed = unsafeNewIORef a Nothing
1110+ }
1111+
1112+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1113+coincidence a = eventCoincidence $ Coincidence
1114+ { coincidenceParent = a
1115+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1116+ }
1117+
1118+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1119+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1120+run roots after = do
1121+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1122+ t <- SpiderHost ask
1123+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1124+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1125+ occBefore <- liftIO $ do
1126+ occBefore <- readIORef occRef
1127+ writeIORef occRef $! DMap.insert k a occBefore
1128+ return occBefore
1129+ if DMap.null occBefore
1130+ then do scheduleRootClear occRef
1131+ return $ Just r
1132+ else return Nothing
1133+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1134+ propagate a subscribersRef
1135+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1136+ let go = do
1137+ delayed <- liftIO $ readIORef delayedRef
1138+ case IntMap.minViewWithKey delayed of
1139+ Nothing -> return ()
1140+ Just ((currentHeight, cur), future) -> do
1141+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1142+ putCurrentHeight $ Height currentHeight
1143+ liftIO $ writeIORef delayedRef $! future
1144+ sequence_ cur
1145+ go
1146+ go
1147+ putCurrentHeight maxBound
1148+ after
1149+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1150+ return result
1151+
1152+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1153+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1154+ height <- liftIO $ readIORef heightRef
1155+ currentHeight <- getCurrentHeight
1156+ case height `compare` currentHeight of
1157+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1158+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1159+ EQ -> a
1160+
1161+data SomeClear = forall a. SomeClear (IORef (Maybe a))
1162+
1163+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1164+
1165+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1166+
1167+debugFinalize :: Bool
1168+debugFinalize = False
1169+
1170+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1171+mkWeakPtrWithDebug x debugNote = do
1172+ x' <- evaluate x
1173+ mkWeakPtr x' $
1174+ if debugFinalize
1175+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1176+ else Nothing
1177+
1178+type WeakList a = [Weak a]
1179+
1180+{-# INLINE withIncreasedDepth #-}
1181+#ifdef DEBUG
1182+withIncreasedDepth :: CanTrace x m => m a -> m a
1183+withIncreasedDepth a = do
1184+ spiderTimeline <- askSpiderTimelineEnv
1185+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1186+ result <- a
1187+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1188+ return result
1189+#else
1190+withIncreasedDepth :: m a -> m a
1191+withIncreasedDepth = id
1192+#endif
1193+
1194+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1195+
1196+{-# INLINE tracePropagate #-}
1197+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1198+tracePropagate p = traceWhen p debugPropagate
1199+
1200+{-# INLINE traceInvalidate #-}
1201+traceInvalidate :: String -> IO ()
1202+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1203+
1204+{-# INLINE traceWhen #-}
1205+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1206+traceWhen p b message = traceMWhen p b $ return message
1207+
1208+{-# INLINE traceMWhen #-}
1209+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1210+traceMWhen _ b getMessage = when b $ do
1211+ message <- getMessage
1212+#ifdef DEBUG
1213+ spiderTimeline <- askSpiderTimelineEnv
1214+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1215+#else
1216+ let d = 0
1217+#endif
1218+ liftIO $ putStrLn $ replicate d ' ' <> message
1219+
1220+whoCreatedIORef :: IORef a -> IO [String]
1221+whoCreatedIORef (IORef a) = whoCreated $! a
1222+
1223+#ifdef DEBUG_CYCLES
1224+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1225+groupByHead = \case
1226+ [] -> []
1227+ (x :| xs) : t -> case groupByHead t of
1228+ [] -> [(x, xs :| [])]
1229+ l@((y, yss) : t')
1230+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1231+ | otherwise -> (x, xs :| []) : l
1232+
1233+listsToForest :: Eq a => [[a]] -> Forest a
1234+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1235+#endif
1236+
1237+{-# INLINE propagateSubscriberHold #-}
1238+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1239+propagateSubscriberHold h a = do
1240+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1241+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1242+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1243+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1244+ case {-# SCC "apply" #-} apply a v of
1245+ Nothing -> return ()
1246+ Just v' -> do
1247+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1248+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1249+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1250+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1251+
1252+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1253+
1254+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1255+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1256+
1257+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1258+askInvalidator = do
1259+ (!m, _) <- BehaviorM ask
1260+ case m of
1261+ Nothing -> return Nothing
1262+ Just (!wi, _) -> return $ Just wi
1263+
1264+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1265+askParentsRef = do
1266+ (!m, _) <- BehaviorM ask
1267+ case m of
1268+ Nothing -> return Nothing
1269+ Just (_, !p) -> return $ Just p
1270+
1271+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1272+askBehaviorHoldInits = do
1273+ (_, !his) <- BehaviorM ask
1274+ return his
1275+
1276+{-# INLINE getDynHold #-}
1277+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1278+getDynHold d = do
1279+ mh <- liftIO $ readIORef $ unDyn d
1280+ case mh of
1281+ Right h -> return h
1282+ Left (readV0, v') -> do
1283+ holdInits <- getDeferralQueue
1284+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1285+ h <- hold v0 v'
1286+ liftIO $ writeIORef (unDyn d) $ Right h
1287+ return h
1288+
1289+-- Always refers to 0
1290+{-# NOINLINE zeroRef #-}
1291+zeroRef :: IORef Height
1292+zeroRef = unsafePerformIO $ newIORef zeroHeight
1293+
1294+type CanSubscribe x m =
1295+ ( HasSpiderTimeline x
1296+ , HasCurrentHeight x m
1297+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
1298+ , Defer SomeClear m -- Wiping out event firings
1299+ , Defer (SomeAssignment x) m -- Updating state
1300+ , Defer (SomeResetCoincidence x) m
1301+ , m ~ EventM x
1302+ )
1303+
1304+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1305+getRootSubscribed k r sub = do
1306+ mSubscribed <- readIORef $ rootSubscribed r
1307+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1308+ case DMap.lookup k mSubscribed of
1309+ Just subscribed -> {-# SCC "hitRoot" #-} do
1310+ sln <- subscribeRootSubscribed subscribed sub
1311+ occ <- getOcc
1312+ return (sln, subscribed, occ)
1313+ Nothing -> {-# SCC "missRoot" #-} do
1314+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1315+ let !cached = rootSubscribed r
1316+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1317+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1318+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1319+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1320+ writeIORef uninitRef $! uninit
1321+ let subscribed = RootSubscribed
1322+ { rootSubscribedKey = k
1323+ , rootSubscribedCachedSubscribed = cached
1324+ , rootSubscribedOccurrence = getOcc
1325+ , rootSubscribedSubscribers = subs
1326+ , rootSubscribedUninit = uninit
1327+ , rootSubscribedWeakSelf = weakSelf
1328+#ifdef DEBUG_NODEIDS
1329+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1330+#endif
1331+ }
1332+ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1333+ 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
1334+ occ <- getOcc
1335+ return (sln, subscribed, occ)
1336+
1337+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1338+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1339+cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1340+ rootSubscribedUninit self
1341+ modifyIORef' cached $ DMap.delete k
1342+
1343+{-# INLINE subscribeRootSubscribed #-}
1344+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1345+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1346+
1347+{-# INLINABLE getFanSubscribed #-}
1348+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)
1349+getFanSubscribed k f sub = do
1350+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1351+ case mSubscribed of
1352+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1353+ sln <- subscribeFanSubscribed k subscribed sub
1354+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1355+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1356+ Nothing -> {-# SCC "missFan" #-} do
1357+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1358+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1359+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1360+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1361+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1362+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1363+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1364+ occRef <- liftIO $ newIORef parentOcc
1365+ when (isJust parentOcc) $ scheduleClear occRef
1366+ let subscribed = FanSubscribed
1367+ { fanSubscribedCachedSubscribed = fanSubscribed f
1368+ , fanSubscribedOccurrence = occRef
1369+ , fanSubscribedParent = subscription
1370+ , fanSubscribedSubscribers = subscribersRef
1371+#ifdef DEBUG_NODEIDS
1372+ , fanSubscribedNodeId = unsafeNodeId f
1373+#endif
1374+ }
1375+ let !self = (k, subscribed)
1376+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1377+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1378+ liftIO $ writeIORef subscribedRef $! subscribed
1379+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1380+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1381+
1382+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1383+cleanupFanSubscribed (k, subscribed) = do
1384+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1385+ let reducedSubscribers = DMap.delete k subscribers
1386+ if DMap.null reducedSubscribers
1387+ then do
1388+ unsubscribe $ fanSubscribedParent subscribed
1389+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1390+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1391+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1392+
1393+{-# INLINE subscribeFanSubscribed #-}
1394+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1395+subscribeFanSubscribed k subscribed sub = do
1396+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1397+ case DMap.lookup k subscribers of
1398+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1399+ let !self = (k, subscribed)
1400+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1401+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1402+ 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
1403+ return sln
1404+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1405+
1406+{-# INLINABLE getSwitchSubscribed #-}
1407+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)
1408+getSwitchSubscribed s sub = do
1409+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1410+ case mSubscribed of
1411+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1412+ sln <- subscribeSwitchSubscribed subscribed sub
1413+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1414+ return (sln, subscribed, occ)
1415+ Nothing -> {-# SCC "missSwitch" #-} do
1416+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1417+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1418+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1419+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1420+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1421+ wiRef <- liftIO $ newIORef wi
1422+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1423+ holdInits <- getDeferralQueue
1424+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1425+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1426+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1427+ subscriptionRef <- liftIO $ newIORef subscription
1428+ occRef <- liftIO $ newIORef parentOcc
1429+ when (isJust parentOcc) $ scheduleClear occRef
1430+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1431+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1432+ let !subscribed = SwitchSubscribed
1433+ { switchSubscribedCachedSubscribed = switchSubscribed s
1434+ , switchSubscribedOccurrence = occRef
1435+ , switchSubscribedHeight = heightRef
1436+ , switchSubscribedSubscribers = subs
1437+ , switchSubscribedOwnInvalidator = i
1438+ , switchSubscribedOwnWeakInvalidator = wiRef
1439+ , switchSubscribedBehaviorParents = parentsRef
1440+ , switchSubscribedParent = switchParent s
1441+ , switchSubscribedCurrentParent = subscriptionRef
1442+ , switchSubscribedWeakSelf = weakSelf
1443+#ifdef DEBUG_NODEIDS
1444+ , switchSubscribedNodeId = unsafeNodeId s
1445+#endif
1446+ }
1447+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1448+ liftIO $ writeIORef subscribedRef $! subscribed
1449+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1450+ return (slnForSub, subscribed, parentOcc)
1451+
1452+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1453+cleanupSwitchSubscribed subscribed = do
1454+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1455+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1456+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1457+
1458+{-# INLINE subscribeSwitchSubscribed #-}
1459+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1460+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1461+
1462+{-# INLINABLE getCoincidenceSubscribed #-}
1463+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)
1464+getCoincidenceSubscribed c sub = do
1465+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1466+ case mSubscribed of
1467+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1468+ sln <- subscribeCoincidenceSubscribed subscribed sub
1469+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1470+ return (sln, subscribed, occ)
1471+ Nothing -> {-# SCC "missCoincidence" #-} do
1472+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1473+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1474+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1475+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1476+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1477+ (occ, height, mInnerSubd) <- case outerOcc of
1478+ Nothing -> return (Nothing, outerHeight, Nothing)
1479+ Just o -> do
1480+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1481+ return (occ, height, Just innerSubd)
1482+ occRef <- liftIO $ newIORef occ
1483+ when (isJust occ) $ scheduleClear occRef
1484+ heightRef <- liftIO $ newIORef height
1485+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1486+ scheduleClear innerSubdRef
1487+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1488+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1489+ let subscribed = CoincidenceSubscribed
1490+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1491+ , coincidenceSubscribedOccurrence = occRef
1492+ , coincidenceSubscribedHeight = heightRef
1493+ , coincidenceSubscribedSubscribers = subs
1494+ , coincidenceSubscribedOuter = subOuter
1495+ , coincidenceSubscribedOuterParent = outerSubscription
1496+ , coincidenceSubscribedInnerParent = innerSubdRef
1497+ , coincidenceSubscribedWeakSelf = weakSelf
1498+#ifdef DEBUG_NODEIDS
1499+ , coincidenceSubscribedNodeId = unsafeNodeId c
1500+#endif
1501+ }
1502+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1503+ liftIO $ writeIORef subscribedRef $! subscribed
1504+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1505+ return (slnForSub, subscribed, occ)
1506+
1507+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1508+cleanupCoincidenceSubscribed subscribed = do
1509+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1510+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1511+
1512+{-# INLINE subscribeCoincidenceSubscribed #-}
1513+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1514+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1515+
1516+{-# INLINE merge #-}
1517+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1518+merge d = cacheEvent (mergeCheap d)
1519+
1520+{-# INLINE [1] mergeCheap #-}
1521+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1522+mergeCheap d = Event $ \sub -> do
1523+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1524+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1525+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1526+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1527+ parentsRef <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1528+ let scheduleSelf height = scheduleMerge' height heightRef $ do
1529+ m <- liftIO $ readIORef accumRef
1530+ liftIO $ writeIORef accumRef $! DMap.empty
1531+ --TODO: Assert that m is not empty
1532+ subscriberPropagate sub m
1533+ invalidateMyHeight = do
1534+ oldHeight <- readIORef heightRef
1535+ 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
1536+ writeIORef heightRef $! invalidHeight
1537+ subscriberInvalidateHeight sub oldHeight
1538+ revalidateMyHeight = do
1539+ currentHeight <- readIORef heightRef
1540+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1541+ heights <- readIORef heightBagRef
1542+ parents <- readIORef parentsRef
1543+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1544+ case heightBagSize heights `compare` DMap.size parents of
1545+ LT -> return ()
1546+ EQ -> do
1547+ let height = succHeight $ heightBagMax heights
1548+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1549+ writeIORef heightRef $! height
1550+ subscriberRecalculateHeight sub height
1551+ GT -> error $ "revalidateMergeHeight: more heights than parents for Merge"
1552+ subscriber :: forall a. k a -> Subscriber x a
1553+ subscriber k = Subscriber
1554+ { subscriberPropagate = \a -> do
1555+ oldM <- liftIO $ readIORef accumRef
1556+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1557+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1558+ liftIO $ writeIORef accumRef $! newM
1559+ when (DMap.null oldM) $ do -- Only schedule the firing once
1560+ height <- liftIO $ readIORef heightRef
1561+ --TODO: assertions about height
1562+ currentHeight <- getCurrentHeight
1563+ when (height <= currentHeight) $ do
1564+ if height /= invalidHeight
1565+ then do
1566+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1567+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1568+ else liftIO $ do
1569+#ifdef DEBUG_CYCLES
1570+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1571+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1572+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1573+#else
1574+ let cycleInfo = ""
1575+#endif
1576+ error $ "Causality loop found" <> cycleInfo
1577+ scheduleSelf height
1578+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1579+ modifyIORef' heightBagRef $ heightBagRemove old
1580+ invalidateMyHeight
1581+ , subscriberRecalculateHeight = \new -> do
1582+ modifyIORef' heightBagRef $ heightBagAdd new
1583+ revalidateMyHeight
1584+ }
1585+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1586+ let s = subscriber k
1587+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1588+ height <- liftIO $ getEventSubscribedHeight parentSubd
1589+ return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1590+ let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1591+ heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1592+ myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1593+ myHeight = if invalidHeight `elem` heights
1594+ then invalidHeight
1595+ else succHeight $ heightBagMax myHeightBag
1596+ currentHeight <- getCurrentHeight
1597+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1598+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1599+ else (Nothing, dm)
1600+ unless (DMap.null accum) $ do
1601+ scheduleSelf myHeight
1602+ occRef <- liftIO $ newIORef occ
1603+ when (isJust occ) $ scheduleClear occRef
1604+ liftIO $ writeIORef accumRef $! accum
1605+ liftIO $ writeIORef heightRef $! myHeight
1606+ liftIO $ writeIORef heightBagRef $! myHeightBag
1607+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1608+ liftIO $ writeIORef parentsRef $! DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1609+ let updateMe (PatchDMap p) = do
1610+ oldParents <- liftIO $ readIORef parentsRef
1611+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1612+ (mOldSubd, newPs) <- case me of
1613+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1614+ Just e -> do
1615+ let s = subscriber k
1616+ subscription@(EventSubscription _ subd) <- subscribe e s
1617+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1618+ let newParent = MergeSubscribedParent subscription
1619+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1620+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1621+ forM_ mOldSubd $ \oldSubd -> do
1622+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1623+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1624+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1625+ (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
1626+ liftIO $ writeIORef parentsRef $! newParents
1627+ return subscriptionsToKill
1628+ defer $ SomeMergeInit $ do
1629+ let s = Subscriber
1630+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1631+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1632+ defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight
1633+ , subscriberInvalidateHeight = \_ -> return ()
1634+ , subscriberRecalculateHeight = \_ -> return ()
1635+ }
1636+ (EventSubscription _ changeSubd, change) <- subscribeAndRead (dynamicUpdated d) s
1637+ forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight
1638+ liftIO $ writeIORef changeSubdRef (s, changeSubd)
1639+ let unsubscribeAll = do
1640+ parents <- readIORef parentsRef
1641+ forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s
1642+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1643+ , occ
1644+ )
1645+
1646+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
1647+
1648+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
1649+fan e =
1650+ let f = Fan
1651+ { fanParent = e
1652+ , fanSubscribed = unsafeNewIORef e Nothing
1653+ }
1654+ in EventSelector $ \k -> eventFan k f
1655+
1656+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()
1657+runHoldInits holdInitRef mergeInitRef = do
1658+ holdInits <- liftIO $ readIORef holdInitRef
1659+ mergeInits <- liftIO $ readIORef mergeInitRef
1660+ unless (null holdInits && null mergeInits) $ do
1661+ liftIO $ writeIORef holdInitRef []
1662+ liftIO $ writeIORef mergeInitRef []
1663+ mapM_ initHold holdInits
1664+ mapM_ unSomeMergeInit mergeInits
1665+ runHoldInits holdInitRef mergeInitRef
1666+
1667+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
1668+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1669+
1670+newEventEnv :: IO (EventEnv x)
1671+newEventEnv = do
1672+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1673+ holdInitRef <- newIORef []
1674+ mergeUpdateRef <- newIORef []
1675+ mergeInitRef <- newIORef []
1676+ heightRef <- newIORef zeroHeight
1677+ toClearRef <- newIORef []
1678+ toClearRootRef <- newIORef []
1679+ coincidenceInfosRef <- newIORef []
1680+ delayedRef <- newIORef IntMap.empty
1681+ return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1682+
1683+clearEventEnv :: EventEnv x -> IO ()
1684+clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
1685+ writeIORef toAssignRef []
1686+ writeIORef holdInitRef []
1687+ writeIORef mergeUpdateRef []
1688+ writeIORef mergeInitRef []
1689+ writeIORef heightRef zeroHeight
1690+ writeIORef toClearRef []
1691+ writeIORef toClearRootRef []
1692+ writeIORef coincidenceInfosRef []
1693+ writeIORef delayedRef IntMap.empty
1694+
1695+-- | Run an event action outside of a frame
1696+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1697+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
1698+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
1699+ let go = do
1700+ result <- a
1701+ 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
1702+ return result
1703+ result <- runEventM go
1704+ toClear <- readIORef $ eventEnvClears env
1705+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1706+ toClearRoot <- readIORef $ eventEnvRootClears env
1707+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1708+ toAssign <- readIORef $ eventEnvAssignments env
1709+ toReconnectRef <- newIORef []
1710+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
1711+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1712+ writeIORef vRef v
1713+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
1714+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1715+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
1716+ writeIORef (eventEnvMergeUpdates env) []
1717+ when debugPropagate $ putStrLn "Updating merges"
1718+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
1719+ when debugPropagate $ putStrLn "Updating merges done"
1720+ toReconnect <- readIORef toReconnectRef
1721+ clearEventEnv env
1722+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1723+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1724+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1725+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
1726+ finalize wi
1727+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1728+ wi' <- mkWeakPtrWithDebug i "wi'"
1729+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
1730+ writeIORef (switchSubscribedBehaviorParents subscribed) []
1731+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
1732+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
1733+ 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
1734+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1735+ sub <- newSubscriberSwitch subscribed
1736+ 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
1737+ {-
1738+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1739+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1740+ EventRoot _ -> "EventRoot"
1741+ EventNever -> "EventNever"
1742+ _ -> "something else"
1743+ -}
1744+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1745+ return oldSubscription
1746+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
1747+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
1748+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1749+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1750+ parentHeight <- getEventSubscribedHeight subd'
1751+ myHeight <- readIORef $ switchSubscribedHeight subscribed
1752+ when (parentHeight /= myHeight) $ do
1753+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1754+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1755+ 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
1756+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1757+ unsubscribe subscription
1758+ mapM_ invalidateCoincidenceHeight mcs
1759+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1760+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
1761+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1762+ height <- calculateSwitchHeight subscribed
1763+ updateSwitchHeight height subscribed
1764+ return result
1765+
1766+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1767+
1768+{-# INLINE zeroHeight #-}
1769+zeroHeight :: Height
1770+zeroHeight = Height 0
1771+
1772+{-# INLINE invalidHeight #-}
1773+invalidHeight :: Height
1774+invalidHeight = Height (-1000)
1775+
1776+#ifdef DEBUG_CYCLES
1777+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1778+{-# INLINE invalidHeightBeingTraversed #-}
1779+invalidHeightBeingTraversed :: Height
1780+invalidHeightBeingTraversed = Height (-1001)
1781+#endif
1782+
1783+{-# INLINE succHeight #-}
1784+succHeight :: Height -> Height
1785+succHeight h@(Height a) =
1786+ if h == invalidHeight
1787+ then invalidHeight
1788+ else Height $ succ a
1789+
1790+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1791+invalidateCoincidenceHeight subscribed = do
1792+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1793+ when (oldHeight /= invalidHeight) $ do
1794+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
1795+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1796+
1797+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
1798+updateSwitchHeight new subscribed = do
1799+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1800+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1801+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1802+ writeIORef (switchSubscribedHeight subscribed) $! new
1803+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1804+
1805+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
1806+recalculateCoincidenceHeight subscribed = do
1807+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1808+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1809+ height <- calculateCoincidenceHeight subscribed
1810+ when (height /= invalidHeight) $ do
1811+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
1812+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1813+
1814+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
1815+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1816+
1817+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
1818+calculateCoincidenceHeight subscribed = do
1819+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1820+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1821+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1822+
1823+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
1824+
1825+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
1826+invalidate toReconnectRef wis = do
1827+ forM_ wis $ \wi -> do
1828+ mi <- deRefWeak wi
1829+ case mi of
1830+ Nothing -> do
1831+ traceInvalidate "invalidate Dead"
1832+ return () --TODO: Should we clean this up here?
1833+ Just i -> do
1834+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1835+ case i of
1836+ InvalidatorPull p -> do
1837+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
1838+ mVal <- readIORef $ pullValue p
1839+ forM_ mVal $ \val -> do
1840+ writeIORef (pullValue p) Nothing
1841+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1842+ InvalidatorSwitch subscribed -> do
1843+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
1844+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1845+ return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
1846+
1847+--------------------------------------------------------------------------------
1848+-- Reflex integration
1849+--------------------------------------------------------------------------------
1850+
1851+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1852+-- When we're specializing, we include this from Reflex.Class instead, because
1853+-- it needs access to these types; when we're not, we want them here, so our
1854+-- instance isn't an orphan instance.
1855+#include "SpiderTimeline.include.hs"
1856+#include "SpiderTimelineHost.include.hs"
1857+#endif
1858+
1859+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
1860+unsafeNewSpiderTimelineEnv = do
1861+ lock <- newMVar ()
1862+ env <- newEventEnv
1863+#ifdef DEBUG
1864+ depthRef <- newIORef 0
1865+#endif
1866+ return $ SpiderTimelineEnv
1867+ { _spiderTimeline_lock = lock
1868+ , _spiderTimeline_eventEnv = env
1869+#ifdef DEBUG
1870+ , _spiderTimeline_depth = depthRef
1871+#endif
1872+ }
1873+
1874+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1875+-- | Create a new SpiderTimelineEnv
1876+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
1877+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
1878+
1879+data LocalSpiderTimeline x s
1880+
1881+instance Reifies s (SpiderTimelineEnv x) =>
1882+ HasSpiderTimeline (LocalSpiderTimeline x s) where
1883+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
1884+
1885+localSpiderTimeline
1886+ :: Proxy s
1887+ -> SpiderTimelineEnv x
1888+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
1889+localSpiderTimeline _ = unsafeCoerce
1890+
1891+-- | Pass a new timeline to the given function.
1892+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
1893+withSpiderTimeline k = do
1894+ env <- unsafeNewSpiderTimelineEnv
1895+ reify env $ \s -> k $ localSpiderTimeline s env
1896+#endif
1897+
1898+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1899+
1900+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1901+
1902+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1903+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
1904+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
1905+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
1906+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
1907+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
1908+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
1909+ type PullM (SpiderTimeline x) = SpiderPullM x
1910+ type PushM (SpiderTimeline x) = SpiderPushM x
1911+ {-# INLINABLE never #-}
1912+ never = SpiderEvent eventNever
1913+ {-# INLINABLE constant #-}
1914+ constant = SpiderBehavior . behaviorConst
1915+ {-# INLINE push #-}
1916+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
1917+ {-# INLINABLE pull #-}
1918+ pull = SpiderBehavior . pull . coerce
1919+ {-# INLINABLE merge #-}
1920+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
1921+ {-# INLINABLE fan #-}
1922+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1923+ {-# INLINABLE switch #-}
1924+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
1925+ {-# INLINABLE coincidence #-}
1926+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
1927+ {-# INLINABLE current #-}
1928+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
1929+ {-# INLINABLE updated #-}
1930+ updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic
1931+ {-# INLINABLE unsafeBuildDynamic #-}
1932+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'
1933+ {-# INLINABLE unsafeBuildIncremental #-}
1934+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1935+ {-# INLINABLE mergeIncremental #-}
1936+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
1937+ {-# INLINABLE currentIncremental #-}
1938+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
1939+ {-# INLINABLE updatedIncremental #-}
1940+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
1941+ {-# INLINABLE incrementalToDynamic #-}
1942+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
1943+ c <- readBehaviorUntracked $ dynamicCurrent i
1944+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
1945+ eventCoercion Coercion = Coercion
1946+ behaviorCoercion Coercion = Coercion
1947+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
1948+#endif
1949+
1950+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
1951+
1952+data SpiderEventHandle x a = SpiderEventHandle
1953+ { spiderEventHandleSubscription :: EventSubscription x
1954+ , spiderEventHandleValue :: IORef (Maybe a)
1955+ }
1956+
1957+instance MonadRef (EventM x) where
1958+ type Ref (EventM x) = Ref IO
1959+ {-# INLINABLE newRef #-}
1960+ {-# INLINABLE readRef #-}
1961+ {-# INLINABLE writeRef #-}
1962+ newRef = liftIO . newRef
1963+ readRef = liftIO . readRef
1964+ writeRef r a = liftIO $ writeRef r a
1965+
1966+instance MonadAtomicRef (EventM x) where
1967+ {-# INLINABLE atomicModifyRef #-}
1968+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
1969+
1970+-- | The monad for actions that manipulate a Spider timeline identified by @x@
1971+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1972+
1973+instance Monad (SpiderHost x) where
1974+ {-# INLINABLE (>>=) #-}
1975+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
1976+ {-# INLINABLE (>>) #-}
1977+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
1978+ {-# INLINABLE return #-}
1979+ return x = SpiderHost $ return x
1980+ {-# INLINABLE fail #-}
1981+ fail s = SpiderHost $ fail s
1982+
1983+-- | Run an action affecting the global Spider timeline; this will be guarded by
1984+-- a mutex for that timeline
1985+runSpiderHost :: SpiderHost Global a -> IO a
1986+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
1987+
1988+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1989+-- | Run an action affecting a given Spider timeline; this will be guarded by a
1990+-- mutex for that timeline
1991+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
1992+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
1993+#endif
1994+
1995+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1996+
1997+instance Monad (SpiderHostFrame x) where
1998+ {-# INLINABLE (>>=) #-}
1999+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2000+ {-# INLINABLE (>>) #-}
2001+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2002+ {-# INLINABLE return #-}
2003+ return x = SpiderHostFrame $ return x
2004+ {-# INLINABLE fail #-}
2005+ fail s = SpiderHostFrame $ fail s
2006+
2007+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2008+newEventWithTriggerIO f = do
2009+ es <- newFanEventWithTriggerIO $ \Refl -> f
2010+ return $ select es Refl
2011+
2012+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2013+newFanEventWithTriggerIO f = do
2014+ occRef <- newIORef DMap.empty
2015+ subscribedRef <- newIORef DMap.empty
2016+ let !r = Root
2017+ { rootOccurrence = occRef
2018+ , rootSubscribed = subscribedRef
2019+ , rootInit = f
2020+ }
2021+ return $ EventSelector $ \k -> eventRoot k r
2022+
2023+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2024+
2025+instance MonadRef (SpiderHost x) where
2026+ type Ref (SpiderHost x) = Ref IO
2027+ newRef = SpiderHost . newRef
2028+ readRef = SpiderHost . readRef
2029+ writeRef r = SpiderHost . writeRef r
2030+
2031+instance MonadAtomicRef (SpiderHost x) where
2032+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2033+
2034+instance MonadRef (SpiderHostFrame x) where
2035+ type Ref (SpiderHostFrame x) = Ref IO
2036+ newRef = SpiderHostFrame . newRef
2037+ readRef = SpiderHostFrame . readRef
2038+ writeRef r = SpiderHostFrame . writeRef r
2039+
2040+instance MonadAtomicRef (SpiderHostFrame x) where
2041+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2042+
2043+instance PrimMonad (SpiderHostFrame x) where
2044+ type PrimState (SpiderHostFrame x) = PrimState IO
2045+ primitive = SpiderHostFrame . EventM . primitive