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