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