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