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