@@ -0,0 +1,2045 @@
1+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
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 #-}
23+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
24+{-# OPTIONS_GHC -fno-warn-orphans #-}
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
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
41+import Data.Dependent.Map (DMap, DSum (..))
42+import qualified Data.Dependent.Map as DMap
43+import Data.Foldable hiding (concat, elem, sequence_)
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
52+import Data.List hiding (foldl')
54+import Data.Monoid ((<>))
57+import Data.Traversable
60+import GHC.IORef (IORef (..))
62+import Reflex.FunctorMaybe
63+import System.IO.Unsafe
64+import System.Mem.Weak
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)
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
88+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
89+import Prelude hiding (any, concat, mapM, mapM_, sequence)
91+debugPropagate :: Bool
93+debugInvalidateHeight :: Bool
95+debugInvalidate :: Bool
101+debugPropagate = True
103+debugInvalidateHeight = False
105+debugInvalidate = True
107+class HasNodeId a where
108+ getNodeId :: a -> Int
110+instance HasNodeId (Hold x p a) where
111+ getNodeId = holdNodeId
113+instance HasNodeId (PushSubscribed x a b) where
114+ getNodeId = pushSubscribedNodeId
116+instance HasNodeId (SwitchSubscribed x a) where
117+ getNodeId = switchSubscribedNodeId
119+instance HasNodeId (FanSubscribed x a) where
120+ getNodeId = fanSubscribedNodeId
122+instance HasNodeId (CoincidenceSubscribed x a) where
123+ getNodeId = coincidenceSubscribedNodeId
125+instance HasNodeId (RootSubscribed x a) where
126+ getNodeId = rootSubscribedNodeId
128+instance HasNodeId (Pull x a) where
129+ getNodeId = pullNodeId
131+{-# INLINE showNodeId #-}
132+showNodeId :: HasNodeId a => a -> String
133+showNodeId = ("#"<>) . show . getNodeId
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"
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"
164+debugPropagate = False
166+debugInvalidateHeight = False
168+debugInvalidate = False
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
178+{-# NOINLINE nextNodeIdRef #-}
179+nextNodeIdRef :: IORef Int
180+nextNodeIdRef = unsafePerformIO $ newIORef 1
183+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
185+{-# NOINLINE unsafeNodeId #-}
186+unsafeNodeId :: a -> Int
187+unsafeNodeId a = unsafePerformIO $ do
192+--------------------------------------------------------------------------------
194+--------------------------------------------------------------------------------
196+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
198+{-# INLINE subscribeAndRead #-}
199+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
200+subscribeAndRead = unEvent
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
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
219+ occ' <- join <$> mapM (runComputeM . f) occ
220+ return (subscription, occ')
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))
230+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
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
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
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
249+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
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
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
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)
277+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
278+cleanupCacheSubscribed self = do
279+ unsubscribe $ _cacheSubscribed_parent self
280+ writeIORef (_cacheSubscribed_cached self) Nothing
282+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
283+subscribe e s = fst <$> subscribeAndRead e s
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
290+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
292+eventRoot :: GCompare k => k a -> Root x k -> Event x a
293+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
295+eventNever :: Event x a
296+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
298+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
299+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
301+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
302+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
304+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
305+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
307+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
308+eventHold !h = Event $ subscribeHoldEvent h
310+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
311+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
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)
323+--------------------------------------------------------------------------------
325+--------------------------------------------------------------------------------
327+data Subscriber x a = Subscriber
328+ { subscriberPropagate :: !(a -> EventM x ())
329+ , subscriberInvalidateHeight :: !(Height -> IO ())
330+ , subscriberRecalculateHeight :: !(Height -> IO ())
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.
340+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
341+-- the weak pointer to it in some cases.
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 ()
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_
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"
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"
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
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"
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
431+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
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"
446+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
447+invalidateSubscriberHeight = flip subscriberInvalidateHeight
449+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
450+recalculateSubscriberHeight = flip subscriberRecalculateHeight
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
459+--------------------------------------------------------------------------------
461+--------------------------------------------------------------------------------
466+data EventSubscribed x = EventSubscribed
467+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
468+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
470+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
471+ , eventSubscribedHasOwnHeightRef :: !Bool
472+ , eventSubscribedWhoCreated :: !(IO [String])
476+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
477+eventSubscribedRoot !r = EventSubscribed
478+ { eventSubscribedHeightRef = zeroRef
479+ , eventSubscribedRetained = toAny r
481+ , eventSubscribedGetParents = return []
482+ , eventSubscribedHasOwnHeightRef = False
483+ , eventSubscribedWhoCreated = return ["root"]
487+eventSubscribedNever :: EventSubscribed x
488+eventSubscribedNever = EventSubscribed
489+ { eventSubscribedHeightRef = zeroRef
490+ , eventSubscribedRetained = toAny ()
492+ , eventSubscribedGetParents = return []
493+ , eventSubscribedHasOwnHeightRef = False
494+ , eventSubscribedWhoCreated = return ["never"]
498+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
499+eventSubscribedFan !subscribed = EventSubscribed
500+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
501+ , eventSubscribedRetained = toAny subscribed
503+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
504+ , eventSubscribedHasOwnHeightRef = False
505+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
509+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
510+eventSubscribedSwitch !subscribed = EventSubscribed
511+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
512+ , eventSubscribedRetained = toAny subscribed
514+ , eventSubscribedGetParents = do
515+ s <- readIORef $ switchSubscribedCurrentParent subscribed
516+ return [Some.This $ _eventSubscription_subscribed s]
517+ , eventSubscribedHasOwnHeightRef = True
518+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
522+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
523+eventSubscribedCoincidence !subscribed = EventSubscribed
524+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
525+ , eventSubscribedRetained = toAny subscribed
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
537+getEventSubscribedHeight :: EventSubscribed x -> IO Height
538+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
541+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
542+whoCreatedEventSubscribed = eventSubscribedWhoCreated
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
556+{-# INLINE subscribeHoldEvent #-}
557+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
558+subscribeHoldEvent = subscribeAndRead . holdEvent
560+--------------------------------------------------------------------------------
562+--------------------------------------------------------------------------------
564+data EventSubscription x = EventSubscription
565+ { _eventSubscription_unsubscribe :: !(IO ())
566+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
569+unsubscribe :: EventSubscription x -> IO ()
570+unsubscribe (EventSubscription u _) = u
572+--------------------------------------------------------------------------------
574+--------------------------------------------------------------------------------
576+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
578+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
579+behaviorHold !h = Behavior $ readHoldTracked h
581+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
582+behaviorHoldIdentity = behaviorHold
584+behaviorConst :: a -> Behavior x a
585+behaviorConst !a = Behavior $ return a
587+behaviorPull :: Pull x a -> Behavior x a
588+behaviorPull !p = Behavior $ do
589+ val <- liftIO $ readIORef $ pullValue p
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
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
610+ liftIO $ writeIORef (pullValue p) $ Just subscribed
611+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
614+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
615+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
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) :))
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
631+--------------------------------------------------------------------------------
633+--------------------------------------------------------------------------------
635+data Dynamic x p = Dynamic
636+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
637+ , dynamicUpdated :: !(Event x p)
640+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
641+dynamicHold !h = Dynamic
642+ { dynamicCurrent = behaviorHold h
643+ , dynamicUpdated = eventHold h
646+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
647+dynamicHoldIdentity = dynamicHold
649+dynamicConst :: PatchTarget p -> Dynamic x p
650+dynamicConst !a = Dynamic
651+ { dynamicCurrent = behaviorConst a
652+ , dynamicUpdated = eventNever
655+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
656+dynamicDyn !d = Dynamic
657+ { dynamicCurrent = behaviorDyn d
658+ , dynamicUpdated = eventDyn d
661+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
662+dynamicDynIdentity = dynamicDyn
664+--------------------------------------------------------------------------------
666+--------------------------------------------------------------------------------
668+--TODO: Figure out why certain things are not 'representational', then make them
669+--representational so we can use coerce
671+--type role Hold representational
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
684+{-# NOINLINE globalSpiderTimelineEnv #-}
685+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
686+!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
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)
694+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
697+type role SpiderTimelineEnv nominal
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
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 ()]))
716+{-# INLINE runEventM #-}
717+runEventM :: EventM x a -> IO a
720+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
721+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
723+class MonadIO m => Defer a m where
724+ getDeferralQueue :: m (IORef [a])
727+defer :: Defer a m => a -> m ()
729+ q <- getDeferralQueue
730+ liftIO $ modifyIORef' q (a:)
732+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
733+ {-# INLINE getDeferralQueue #-}
734+ getDeferralQueue = asksEventEnv eventEnvAssignments
736+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
737+ {-# INLINE getDeferralQueue #-}
738+ getDeferralQueue = asksEventEnv eventEnvHoldInits
740+instance Defer (SomeHoldInit x) (BehaviorM x) where
741+ {-# INLINE getDeferralQueue #-}
742+ getDeferralQueue = BehaviorM $ asks snd
744+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
745+ {-# INLINE getDeferralQueue #-}
746+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
748+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
749+ {-# INLINE getDeferralQueue #-}
750+ getDeferralQueue = asksEventEnv eventEnvMergeInits
752+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
753+ getCurrentHeight :: m Height
754+ scheduleMerge :: Height -> EventM x () -> m ()
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]
766+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
767+class x ~ Global => HasSpiderTimeline x where
769+class HasSpiderTimeline x where
771+ -- | Retrieve the current SpiderTimelineEnv
772+ spiderTimeline :: SpiderTimelineEnv x
774+instance HasSpiderTimeline Global where
775+ spiderTimeline = globalSpiderTimelineEnv
777+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
778+putCurrentHeight h = do
779+ heightRef <- asksEventEnv eventEnvCurrentHeight
780+ liftIO $ writeIORef heightRef $! h
782+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
783+ {-# INLINE getDeferralQueue #-}
784+ getDeferralQueue = asksEventEnv eventEnvClears
786+{-# INLINE scheduleClear #-}
787+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
788+scheduleClear r = defer $ SomeClear r
790+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
791+ {-# INLINE getDeferralQueue #-}
792+ getDeferralQueue = asksEventEnv eventEnvRootClears
794+{-# INLINE scheduleRootClear #-}
795+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
796+scheduleRootClear r = defer $ SomeRootClear r
798+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
799+ {-# INLINE getDeferralQueue #-}
800+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
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)
806+ valRef <- liftIO $ newIORef v0
807+ invsRef <- liftIO $ newIORef []
808+ parentRef <- liftIO $ newIORef Nothing
810+ nodeId <- liftIO newNodeId
813+ { holdValue = valRef
814+ , holdInvalidators = invsRef
816+ , holdParent = parentRef
818+ , holdNodeId = nodeId
821+ defer $ SomeHoldInit h
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
829+ Just subd -> return subd
832+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
833+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
834+ liftIO $ writeIORef subscriptionRef $! subscription
836+ Nothing -> return ()
838+ old <- liftIO $ readIORef $ holdValue h
840+ Nothing -> return ()
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
849+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
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)
855+instance Monad (BehaviorM x) where
856+ {-# INLINE (>>=) #-}
857+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
859+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
860+ {-# INLINE return #-}
861+ return x = BehaviorM $ return x
863+ fail s = BehaviorM $ fail s
865+data BehaviorSubscribed x a
866+ = forall p. BehaviorSubscribedHold (Hold x p)
867+ | BehaviorSubscribedPull (PullSubscribed x a)
869+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
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
879+--type role Pull representational
881+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
882+ , pullCompute :: !(BehaviorM x a)
889+ = forall a. InvalidatorPull (Pull x a)
890+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
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?
900+ , rootSubscribedNodeId :: Int
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 ()))
910+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
912+data SomeMergeUpdate x = SomeMergeUpdate
913+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
914+ , _someMergeUpdate_invalidateHeight :: !(IO ())
915+ , _someMergeUpdate_recalculateHeight :: !(IO ())
918+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
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
923+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
925+instance Defer (SomeHoldInit x) (ComputeM x) where
926+ getDeferralQueue = ComputeM ask
928+{-# INLINABLE runComputeM #-}
929+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
930+runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
932+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
934+data HeightBag = HeightBag
935+ { _heightBag_size :: {-# UNPACK #-} !Int
936+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
938+ deriving (Show, Read, Eq, Ord)
940+heightBagEmpty :: HeightBag
941+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
943+heightBagSize :: HeightBag -> Int
944+heightBagSize = _heightBag_size
946+heightBagFromList :: [Height] -> HeightBag
947+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
949+heightBagAdd :: Height -> HeightBag -> HeightBag
950+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
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
959+heightBagMax :: HeightBag -> Height
960+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
961+ Just ((h, _), _) -> Height h
962+ Nothing -> zeroHeight
964+heightBagVerify :: HeightBag -> HeightBag
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
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)))
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)
988+ , fanSubscribedNodeId :: Int
993+ = Fan { fanParent :: !(Event x (DMap k Identity))
994+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
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
1014+ = Switch { switchParent :: !(Behavior x (Event x a))
1015+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
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
1033+data Coincidence x a
1034+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1035+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1038+{-# NOINLINE newInvalidatorSwitch #-}
1039+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1040+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1042+{-# NOINLINE newInvalidatorPull #-}
1043+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1044+newInvalidatorPull p = return $! InvalidatorPull p
1046+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1047+ fmapMaybe f = push $ return . f
1049+instance HasSpiderTimeline x => Align (Event x) where
1051+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1053+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
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)
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
1067+ That (Identity b) -> do
1068+ a <- readBehaviorUntracked $ dynamicCurrent da
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
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')
1078+-- ResultM can read behaviors and events
1079+type ResultM = EventM
1081+{-# NOINLINE unsafeNewIORef #-}
1082+unsafeNewIORef :: a -> b -> IORef b
1083+unsafeNewIORef _ b = unsafePerformIO $ newIORef b
1085+instance HasSpiderTimeline x => Functor (Event x) where
1086+ fmap f = push $ return . Just . f
1088+instance Functor (Behavior x) where
1089+ fmap f = pull . fmap f . readBehaviorTracked
1092+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1093+push f e = cacheEvent (pushCheap f e)
1095+{-# INLINABLE pull #-}
1096+pull :: BehaviorM x a -> Behavior x a
1097+pull a = behaviorPull $ Pull
1099+ , pullValue = unsafeNewIORef a Nothing
1100+#ifdef DEBUG_NODEIDS
1101+ , pullNodeId = unsafeNodeId a
1105+{-# INLINABLE switch #-}
1106+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1107+switch a = eventSwitch $ Switch
1109+ , switchSubscribed = unsafeNewIORef a Nothing
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
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
1129+ if DMap.null occBefore
1130+ then do scheduleRootClear occRef
1132+ else return Nothing
1133+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1134+ propagate a subscribersRef
1135+ delayedRef <- asksEventEnv eventEnvDelayedMerges
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
1147+ putCurrentHeight maxBound
1149+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
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?)
1161+data SomeClear = forall a. SomeClear (IORef (Maybe a))
1163+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1165+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1167+debugFinalize :: Bool
1168+debugFinalize = False
1170+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1171+mkWeakPtrWithDebug x debugNote = do
1175+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1178+type WeakList a = [Weak a]
1180+{-# INLINE withIncreasedDepth #-}
1182+withIncreasedDepth :: CanTrace x m => m a -> m a
1183+withIncreasedDepth a = do
1184+ spiderTimeline <- askSpiderTimelineEnv
1185+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1187+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1190+withIncreasedDepth :: m a -> m a
1191+withIncreasedDepth = id
1194+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1196+{-# INLINE tracePropagate #-}
1197+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1198+tracePropagate p = traceWhen p debugPropagate
1200+{-# INLINE traceInvalidate #-}
1201+traceInvalidate :: String -> IO ()
1202+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1204+{-# INLINE traceWhen #-}
1205+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1206+traceWhen p b message = traceMWhen p b $ return message
1208+{-# INLINE traceMWhen #-}
1209+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1210+traceMWhen _ b getMessage = when b $ do
1211+ message <- getMessage
1213+ spiderTimeline <- askSpiderTimelineEnv
1214+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1218+ liftIO $ putStrLn $ replicate d ' ' <> message
1220+whoCreatedIORef :: IORef a -> IO [String]
1221+whoCreatedIORef (IORef a) = whoCreated $! a
1224+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1227+ (x :| xs) : t -> case groupByHead t of
1228+ [] -> [(x, xs :| [])]
1230+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1231+ | otherwise -> (x, xs :| []) : l
1233+listsToForest :: Eq a => [[a]] -> Forest a
1234+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
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 ()
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'
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
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)
1257+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1259+ (!m, _) <- BehaviorM ask
1261+ Nothing -> return Nothing
1262+ Just (!wi, _) -> return $ Just wi
1264+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1266+ (!m, _) <- BehaviorM ask
1268+ Nothing -> return Nothing
1269+ Just (_, !p) -> return $ Just p
1271+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1272+askBehaviorHoldInits = do
1273+ (_, !his) <- BehaviorM ask
1276+{-# INLINE getDynHold #-}
1277+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1279+ mh <- liftIO $ readIORef $ unDyn d
1281+ Right h -> return h
1282+ Left (readV0, v') -> do
1283+ holdInits <- getDeferralQueue
1284+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1286+ liftIO $ writeIORef (unDyn d) $ Right h
1289+-- Always refers to 0
1290+{-# NOINLINE zeroRef #-}
1291+zeroRef :: IORef Height
1292+zeroRef = unsafePerformIO $ newIORef zeroHeight
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
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
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)
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
1335+ return (sln, subscribed, occ)
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
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
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
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)
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
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
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
1404+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
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
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)
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
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
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)
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
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)
1507+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1508+cleanupCoincidenceSubscribed subscribed = do
1509+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1510+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
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
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)
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
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
1566+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1567+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1570+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1571+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1572+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
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
1581+ , subscriberRecalculateHeight = \new -> do
1582+ modifyIORef' heightBagRef $ heightBagAdd new
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
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)
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
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
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 ()
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)
1646+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
1648+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
1652+ , fanSubscribed = unsafeNewIORef e Nothing
1654+ in EventSelector $ \k -> eventFan k f
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
1667+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
1668+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1670+newEventEnv :: IO (EventEnv x)
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
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
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)
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
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
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
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
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
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"
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
1766+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1768+{-# INLINE zeroHeight #-}
1769+zeroHeight :: Height
1770+zeroHeight = Height 0
1772+{-# INLINE invalidHeight #-}
1773+invalidHeight :: Height
1774+invalidHeight = Height (-1000)
1777+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1778+{-# INLINE invalidHeightBeingTraversed #-}
1779+invalidHeightBeingTraversed :: Height
1780+invalidHeightBeingTraversed = Height (-1001)
1783+{-# INLINE succHeight #-}
1784+succHeight :: Height -> Height
1785+succHeight h@(Height a) =
1786+ if h == invalidHeight
1788+ else Height $ succ a
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
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
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
1814+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
1815+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
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
1823+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
1825+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
1826+invalidate toReconnectRef wis = do
1827+ forM_ wis $ \wi -> do
1831+ traceInvalidate "invalidate Dead"
1832+ return () --TODO: Should we clean this up here?
1834+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
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
1847+--------------------------------------------------------------------------------
1848+-- Reflex integration
1849+--------------------------------------------------------------------------------
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"
1859+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
1860+unsafeNewSpiderTimelineEnv = do
1864+ depthRef <- newIORef 0
1866+ return $ SpiderTimelineEnv
1867+ { _spiderTimeline_lock = lock
1868+ , _spiderTimeline_eventEnv = env
1870+ , _spiderTimeline_depth = depthRef
1874+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1875+-- | Create a new SpiderTimelineEnv
1876+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
1877+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
1879+data LocalSpiderTimeline x s
1881+instance Reifies s (SpiderTimelineEnv x) =>
1882+ HasSpiderTimeline (LocalSpiderTimeline x s) where
1883+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
1887+ -> SpiderTimelineEnv x
1888+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
1889+localSpiderTimeline _ = unsafeCoerce
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
1898+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1900+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
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
1950+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
1952+data SpiderEventHandle x a = SpiderEventHandle
1953+ { spiderEventHandleSubscription :: EventSubscription x
1954+ , spiderEventHandleValue :: IORef (Maybe a)
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
1966+instance MonadAtomicRef (EventM x) where
1967+ {-# INLINABLE atomicModifyRef #-}
1968+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
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)
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
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
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
1995+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
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
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
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
2017+ { rootOccurrence = occRef
2018+ , rootSubscribed = subscribedRef
2021+ return $ EventSelector $ \k -> eventRoot k r
2023+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
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
2031+instance MonadAtomicRef (SpiderHost x) where
2032+ atomicModifyRef r = SpiderHost . atomicModifyRef r
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
2040+instance MonadAtomicRef (SpiderHostFrame x) where
2041+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2043+instance PrimMonad (SpiderHostFrame x) where
2044+ type PrimState (SpiderHostFrame x) = PrimState IO
2045+ primitive = SpiderHostFrame . EventM . primitive