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