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