@@ -9,7 +9,6 @@
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE MultiWayIf #-}
12{-# LANGUAGE MultiWayIf #-}
14{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RoleAnnotations #-}
14{-# LANGUAGE RoleAnnotations #-}
@@ -17,9 +16,15 @@
17{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
19+{-# LANGUAGE PolyKinds #-}
20+{-# LANGUAGE DeriveFunctor #-}
21+{-# LANGUAGE StandaloneDeriving #-}
22+{-# LANGUAGE InstanceSigs #-}
20#ifdef USE_REFLEX_OPTIMIZER
24#ifdef USE_REFLEX_OPTIMIZER
21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
27+{-# OPTIONS_GHC -Wunused-binds #-}
23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -33,7 +38,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
33import Control.Monad.Exception
38import Control.Monad.Exception
34import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
35import Control.Monad.Primitive
40import Control.Monad.Primitive
36−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
41+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42+import Control.Monad.Reader.Class
43+import Control.Monad.IO.Class
44+import Control.Monad.ReaderIO
37import Control.Monad.Ref
45import Control.Monad.Ref
38import Data.Align
46import Data.Align
39import Data.Coerce
47import Data.Coerce
@@ -49,20 +57,30 @@ import Data.GADT.Compare
49import Data.IntMap.Strict (IntMap)
57import Data.IntMap.Strict (IntMap)
50import qualified Data.IntMap.Strict as IntMap
58import qualified Data.IntMap.Strict as IntMap
51import Data.IORef
59import Data.IORef
52−import Data.Maybe
60+import Data.Kind (Type)
61+import Data.Maybe hiding (mapMaybe)
53import Data.Monoid ((<>))
62import Data.Monoid ((<>))
54import Data.Proxy
63import Data.Proxy
55import Data.These
64import Data.These
56import Data.Traversable
65import Data.Traversable
66+import Data.Witherable (Filterable, mapMaybe)
57import GHC.Exts
67import GHC.Exts
58import GHC.IORef (IORef (..))
68import GHC.IORef (IORef (..))
59import GHC.Stack
69import GHC.Stack
60import Reflex.FastWeak
70import Reflex.FastWeak
61−import Reflex.FunctorMaybe
62import System.IO.Unsafe
71import System.IO.Unsafe
63import System.Mem.Weak
72import System.Mem.Weak
64import Unsafe.Coerce
73import Unsafe.Coerce
75+#ifdef MIN_VERSION_semialign
76+#if MIN_VERSION_these(0,8,0)
77+import Data.These.Combinators (justThese)
79+#if MIN_VERSION_semialign(1,1,0)
80+import Data.Zip (Zip (..))
66#ifdef DEBUG_CYCLES
84#ifdef DEBUG_CYCLES
67import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
85import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
68import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
86import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
@@ -74,9 +92,9 @@ import Data.Tree (Forest, Tree (..), drawForest)
74import Data.FastWeakBag (FastWeakBag)
92import Data.FastWeakBag (FastWeakBag)
75import qualified Data.FastWeakBag as FastWeakBag
93import qualified Data.FastWeakBag as FastWeakBag
76import Data.Reflection
94import Data.Reflection
77−import Data.Some (Some)
95+import Data.Some (Some(Some))
78−import qualified Data.Some as Some
79import Data.Type.Coercion
96import Data.Type.Coercion
97+import Data.Profunctor.Unsafe ((#.), (.#))
80import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
98import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
81import qualified Data.WeakBag as WeakBag
99import qualified Data.WeakBag as WeakBag
82import qualified Reflex.Class
100import qualified Reflex.Class
@@ -193,12 +211,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
194newNodeId :: IO Int
212newNodeId :: IO Int
195newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
213newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
197−{-# NOINLINE unsafeNodeId #-}
198−unsafeNodeId :: a -> Int
199−unsafeNodeId a = unsafePerformIO $ do
204--------------------------------------------------------------------------------
216--------------------------------------------------------------------------------
@@ -302,9 +314,10 @@ cacheEvent e =
317+ unsafePerformIO $ do
305− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
318+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
319+ <- newIORef emptyFastWeak
307− in \sub -> {-# SCC "cacheEvent" #-} do
320+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
308#ifdef DEBUG_TRACE_EVENTS
321#ifdef DEBUG_TRACE_EVENTS
309 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
322 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
@@ -319,9 +332,9 @@ cacheEvent e =
319 scheduleClear occRef
332 scheduleClear occRef
320 propagateFast a subscribers
333 propagateFast a subscribers
321 , subscriberInvalidateHeight = \old -> do
334 , subscriberInvalidateHeight = \old -> do
322− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
335+ FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old
323 , subscriberRecalculateHeight = \new -> do
336 , subscriberRecalculateHeight = \new -> do
324− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
337+ FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new
326 when (isJust occ) $ do
339 when (isJust occ) $ do
327 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
340 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
@@ -370,7 +383,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
370eventNever :: Event x a
383eventNever :: Event x a
371eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
384eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
373−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
386+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
374eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
387eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
376eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
389eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -422,14 +435,14 @@ newSubscriberHold h = return $ Subscriber
422 , subscriberRecalculateHeight = \_ -> return ()
435 , subscriberRecalculateHeight = \_ -> return ()
425−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
438+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
426newSubscriberFan subscribed = return $ Subscriber
439newSubscriberFan subscribed = return $ Subscriber
427 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
440 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
428 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
441 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
429 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
442 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
430 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
443 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
431 scheduleClear $ fanSubscribedOccurrence subscribed
444 scheduleClear $ fanSubscribedOccurrence subscribed
432− let f _ (Pair (Identity v) subsubs) = do
445+ let f _ (Pair v subsubs) = do
433 propagate v $ _fanSubscribedChildren_list subsubs
446 propagate v $ _fanSubscribedChildren_list subsubs
434 return $ Constant ()
447 return $ Constant ()
435 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
448 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -437,12 +450,12 @@ newSubscriberFan subscribed = return $ Subscriber
437 , subscriberInvalidateHeight = \old -> do
450 , subscriberInvalidateHeight = \old -> do
438 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
451 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
439 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
452 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
440− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
453+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
441 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
454 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
442 , subscriberRecalculateHeight = \new -> do
455 , subscriberRecalculateHeight = \new -> do
443 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
456 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
444 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
457 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
445− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
458+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
446 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
459 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
@@ -458,7 +471,7 @@ newSubscriberSwitch subscribed = return $ Subscriber
458 oldHeight <- readIORef $ switchSubscribedHeight subscribed
471 oldHeight <- readIORef $ switchSubscribedHeight subscribed
459 when (oldHeight /= invalidHeight) $ do
472 when (oldHeight /= invalidHeight) $ do
460 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
473 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
461− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
474+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
462 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
475 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
463 , subscriberRecalculateHeight = \new -> do
476 , subscriberRecalculateHeight = \new -> do
464 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
477 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
@@ -481,8 +494,8 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber
481 Nothing -> do
494 Nothing -> do
482 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
495 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
483 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
496 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
484− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
497+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
485− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
498+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
486 Just o -> do -- Since it's already firing, no need to adjust height
499 Just o -> do -- Since it's already firing, no need to adjust height
487 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
500 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
488 scheduleClear $ coincidenceSubscribedOccurrence subscribed
501 scheduleClear $ coincidenceSubscribedOccurrence subscribed
@@ -529,14 +542,14 @@ propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
529propagate a subscribers = withIncreasedDepth $ do
542propagate a subscribers = withIncreasedDepth $ do
530 -- 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
543 -- 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
531 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
544 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
532− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
545+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
534-- | Propagate everything at the current height
547-- | Propagate everything at the current height
535propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
548propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
536propagateFast a subscribers = withIncreasedDepth $ do
549propagateFast a subscribers = withIncreasedDepth $ do
537 -- 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
550 -- 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
538 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
551 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
539− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
552+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
541--------------------------------------------------------------------------------
554--------------------------------------------------------------------------------
542-- EventSubscribed
555-- EventSubscribed
@@ -545,6 +558,11 @@ propagateFast a subscribers = withIncreasedDepth $ do
545toAny :: a -> Any
558toAny :: a -> Any
546toAny = unsafeCoerce
559toAny = unsafeCoerce
561+-- Why do we use Any here, instead of just giving eventSubscribedRetained an
562+-- existential type? Sadly, GHC does not currently know how to unbox types
563+-- with existentially quantified fields. So instead we just coerce values
564+-- to type Any on the way in. Since we never coerce them back, this is
548data EventSubscribed x = EventSubscribed
566data EventSubscribed x = EventSubscribed
549 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
567 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
550 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
568 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -577,12 +595,12 @@ eventSubscribedNever = EventSubscribed
580−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
598+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
581eventSubscribedFan !subscribed = EventSubscribed
599eventSubscribedFan !subscribed = EventSubscribed
582 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
600 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
583 , eventSubscribedRetained = toAny subscribed
601 , eventSubscribedRetained = toAny subscribed
584#ifdef DEBUG_CYCLES
602#ifdef DEBUG_CYCLES
585− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
603+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
586 , eventSubscribedHasOwnHeightRef = False
604 , eventSubscribedHasOwnHeightRef = False
587 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
605 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
@@ -595,7 +613,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
595#ifdef DEBUG_CYCLES
613#ifdef DEBUG_CYCLES
596 , eventSubscribedGetParents = do
614 , eventSubscribedGetParents = do
597 s <- readIORef $ switchSubscribedCurrentParent subscribed
615 s <- readIORef $ switchSubscribedCurrentParent subscribed
598− return [Some.This $ _eventSubscription_subscribed s]
616+ return [Some $ _eventSubscription_subscribed s]
599 , eventSubscribedHasOwnHeightRef = True
617 , eventSubscribedHasOwnHeightRef = True
600 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
618 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
@@ -608,8 +626,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
608#ifdef DEBUG_CYCLES
626#ifdef DEBUG_CYCLES
609 , eventSubscribedGetParents = do
627 , eventSubscribedGetParents = do
610 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
628 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
611− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
629+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612− innerParents = maybeToList $ fmap Some.This innerSubscription
630+ innerParents = maybeToList $ fmap Some innerSubscription
613 return $ outerParent : innerParents
631 return $ outerParent : innerParents
614 , eventSubscribedHasOwnHeightRef = True
632 , eventSubscribedHasOwnHeightRef = True
615 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
633 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -625,13 +643,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated
626walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
644walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
627walkInvalidHeightParents s0 = do
645walkInvalidHeightParents s0 = do
628− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
646+ subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
629 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
647 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
630 when (h == invalidHeight) $ do
648 when (h == invalidHeight) $ do
631 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
649 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
632− modify (Some.This s :)
650+ modify (Some s :)
633 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
651 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
634− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
652+ forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
635 return subscribers
653 return subscribers
@@ -659,7 +677,7 @@ behaviorPull !p = Behavior $ do
659 val <- liftIO $ readIORef $ pullValue p
677 val <- liftIO $ readIORef $ pullValue p
660 case val of
678 case val of
661 Just subscribed -> do
679 Just subscribed -> do
662− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
680+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
663 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
681 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
664 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
682 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
665 return $ pullSubscribedValue subscribed
683 return $ pullSubscribedValue subscribed
@@ -668,7 +686,7 @@ behaviorPull !p = Behavior $ do
668 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
686 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
669 parentsRef <- liftIO $ newIORef []
687 parentsRef <- liftIO $ newIORef []
670 holdInits <- askBehaviorHoldInits
688 holdInits <- askBehaviorHoldInits
671− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
689+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
672 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
690 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
673 parents <- liftIO $ readIORef parentsRef
691 parents <- liftIO $ readIORef parentsRef
674 let subscribed = PullSubscribed
692 let subscribed = PullSubscribed
@@ -678,7 +696,7 @@ behaviorPull !p = Behavior $ do
678 , pullSubscribedParents = parents
696 , pullSubscribedParents = parents
680 liftIO $ writeIORef (pullValue p) $ Just subscribed
698 liftIO $ writeIORef (pullValue p) $ Just subscribed
681− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
699+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
684behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
702behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
@@ -689,7 +707,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
689readHoldTracked h = do
707readHoldTracked h = do
690 result <- liftIO $ readIORef $ holdValue h
708 result <- liftIO $ readIORef $ holdValue h
691 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
709 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
692− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
710+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
693 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
711 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
694 return result
712 return result
@@ -703,42 +721,46 @@ readBehaviorUntracked b = do
703-- Dynamic
721-- Dynamic
704--------------------------------------------------------------------------------
722--------------------------------------------------------------------------------
724+type DynamicS x p = Dynamic x (PatchTarget p) p
706−data Dynamic x p = Dynamic
726+data Dynamic x target p = Dynamic
707− { dynamicCurrent :: !(Behavior x (PatchTarget p))
727+ { dynamicCurrent :: !(Behavior x target)
708− , dynamicUpdated :: !(Event x p)
728+ , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
731+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
711−dynamicHold :: Hold x p -> Dynamic x p
736+dynamicHold :: Hold x p -> DynamicS x p
712dynamicHold !h = Dynamic
737dynamicHold !h = Dynamic
713 { dynamicCurrent = behaviorHold h
738 { dynamicCurrent = behaviorHold h
714 , dynamicUpdated = eventHold h
739 , dynamicUpdated = eventHold h
717−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
742+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
718dynamicHoldIdentity = dynamicHold
743dynamicHoldIdentity = dynamicHold
720−dynamicConst :: PatchTarget p -> Dynamic x p
745+dynamicConst :: PatchTarget p -> DynamicS x p
721dynamicConst !a = Dynamic
746dynamicConst !a = Dynamic
722 { dynamicCurrent = behaviorConst a
747 { dynamicCurrent = behaviorConst a
723 , dynamicUpdated = eventNever
748 , dynamicUpdated = eventNever
726−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
751+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
727dynamicDyn !d = Dynamic
752dynamicDyn !d = Dynamic
728 { dynamicCurrent = behaviorDyn d
753 { dynamicCurrent = behaviorDyn d
729 , dynamicUpdated = eventDyn d
754 , dynamicUpdated = eventDyn d
732−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
757+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
733dynamicDynIdentity = dynamicDyn
758dynamicDynIdentity = dynamicDyn
735--------------------------------------------------------------------------------
760--------------------------------------------------------------------------------
736-- Combinators
761-- Combinators
737--------------------------------------------------------------------------------
762--------------------------------------------------------------------------------
739−--TODO: Figure out why certain things are not 'representational', then make them
740−--representational so we can use coerce
742--type role Hold representational
764--type role Hold representational
743data Hold x p
765data Hold x p
744 = Hold { holdValue :: !(IORef (PatchTarget p))
766 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -759,20 +781,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
760-- | Stores all global data relevant to a particular Spider timeline; only one
782-- | Stores all global data relevant to a particular Spider timeline; only one
761-- value should exist for each type @x@
783-- value should exist for each type @x@
784+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
785+-- We implement SpiderTimelineEnv with a newtype wrapper so
786+-- we can get the coercions we want safely.
787+type role SpiderTimelineEnv nominal
762−data SpiderTimelineEnv x = SpiderTimelineEnv
789+data SpiderTimelineEnv' x = SpiderTimelineEnv
763 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
790 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
764 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
791 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
765#ifdef DEBUG
792#ifdef DEBUG
766 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
793 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
769−type role SpiderTimelineEnv nominal
796+type role SpiderTimelineEnv' phantom
771instance Eq (SpiderTimelineEnv x) where
798instance Eq (SpiderTimelineEnv x) where
772 _ == _ = True -- Since only one exists of each type
799 _ == _ = True -- Since only one exists of each type
774instance GEq SpiderTimelineEnv where
801instance GEq SpiderTimelineEnv where
775− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
802+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
776 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
803 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
777 else Nothing
804 else Nothing
@@ -782,9 +809,9 @@ data EventEnv x
782 , eventEnvDynInits :: !(IORef [SomeDynInit x])
809 , eventEnvDynInits :: !(IORef [SomeDynInit x])
783 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
810 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
784 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
811 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
785− , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
812+ , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe
786− , eventEnvIntClears :: !(IORef [SomeIntClear])
813+ , eventEnvIntClears :: !(IORef [Some IntClear])
787− , eventEnvRootClears :: !(IORef [SomeRootClear])
814+ , eventEnvRootClears :: !(IORef [Some RootClear])
788 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
815 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
789 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
816 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
790 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
817 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
@@ -795,7 +822,7 @@ runEventM :: EventM x a -> IO a
795runEventM = unEventM
822runEventM = unEventM
797asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
824asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
798−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
825+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
800class MonadIO m => Defer a m where
827class MonadIO m => Defer a m where
801 getDeferralQueue :: m (IORef [a])
828 getDeferralQueue :: m (IORef [a])
@@ -856,29 +883,29 @@ putCurrentHeight h = do
856 heightRef <- asksEventEnv eventEnvCurrentHeight
883 heightRef <- asksEventEnv eventEnvCurrentHeight
857 liftIO $ writeIORef heightRef $! h
884 liftIO $ writeIORef heightRef $! h
859−instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
886+instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
860 {-# INLINE getDeferralQueue #-}
887 {-# INLINE getDeferralQueue #-}
861 getDeferralQueue = asksEventEnv eventEnvClears
888 getDeferralQueue = asksEventEnv eventEnvClears
863{-# INLINE scheduleClear #-}
890{-# INLINE scheduleClear #-}
864−scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
891+scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
865−scheduleClear r = defer $ SomeClear r
892+scheduleClear r = defer $ Some $ Clear r
867−instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
894+instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
868 {-# INLINE getDeferralQueue #-}
895 {-# INLINE getDeferralQueue #-}
869 getDeferralQueue = asksEventEnv eventEnvIntClears
896 getDeferralQueue = asksEventEnv eventEnvIntClears
871{-# INLINE scheduleIntClear #-}
898{-# INLINE scheduleIntClear #-}
872−scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
899+scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
873−scheduleIntClear r = defer $ SomeIntClear r
900+scheduleIntClear r = defer $ Some $ IntClear r
875−instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
902+instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
876 {-# INLINE getDeferralQueue #-}
903 {-# INLINE getDeferralQueue #-}
877 getDeferralQueue = asksEventEnv eventEnvRootClears
904 getDeferralQueue = asksEventEnv eventEnvRootClears
879{-# INLINE scheduleRootClear #-}
906{-# INLINE scheduleRootClear #-}
880−scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
907+scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
881−scheduleRootClear r = defer $ SomeRootClear r
908+scheduleRootClear r = defer $ Some $ RootClear r
883instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
910instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
884 {-# INLINE getDeferralQueue #-}
911 {-# INLINE getDeferralQueue #-}
@@ -933,9 +960,9 @@ getHoldEventSubscription h = do
934type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
961type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
936−--type role BehaviorM representational
937-- BehaviorM can sample behaviors
963-- BehaviorM can sample behaviors
938−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
964+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
965+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
940instance Monad (BehaviorM x) where
967instance Monad (BehaviorM x) where
941 {-# INLINE (>>=) #-}
968 {-# INLINE (>>=) #-}
@@ -951,7 +978,7 @@ data BehaviorSubscribed x a
951 = forall p. BehaviorSubscribedHold (Hold x p)
978 = forall p. BehaviorSubscribedHold (Hold x p)
952 | BehaviorSubscribedPull (PullSubscribed x a)
979 | BehaviorSubscribedPull (PullSubscribed x a)
954−data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
981+newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))
956--type role PullSubscribed representational
983--type role PullSubscribed representational
957data PullSubscribed x a
984data PullSubscribed x a
@@ -986,7 +1013,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
989−data Root x (k :: * -> *)
1016+data Root x k
990 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1017 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
991 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1018 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
992 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1019 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1056,25 +1083,25 @@ heightBagVerify b@(HeightBag s c) = if
1056heightBagVerify = id
1083heightBagVerify = id
1059−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1086+data FanSubscribedChildren x k v a = FanSubscribedChildren
1060− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1087+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1061− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1088+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1062− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1089+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1065−data FanSubscribed (x :: *) k
1092+data FanSubscribed x k v
1066− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1093+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1067− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1094+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1068− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1095+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1069 , fanSubscribedParent :: !(EventSubscription x)
1096 , fanSubscribedParent :: !(EventSubscription x)
1070#ifdef DEBUG_NODEIDS
1097#ifdef DEBUG_NODEIDS
1071 , fanSubscribedNodeId :: Int
1098 , fanSubscribedNodeId :: Int
1075−data Fan x k
1102+data Fan x k v
1076− = Fan { fanParent :: !(Event x (DMap k Identity))
1103+ = Fan { fanParent :: !(Event x (DMap k v))
1077− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1104+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1080data SwitchSubscribed x a
1107data SwitchSubscribed x a
@@ -1128,24 +1155,35 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1128newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1155newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1129newInvalidatorPull p = return $! InvalidatorPull p
1156newInvalidatorPull p = return $! InvalidatorPull p
1131−instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1158+instance HasSpiderTimeline x => Filterable (Event x) where
1132− fmapMaybe f = push $ return . f
1159+ mapMaybe f = push $ return . f
1134instance HasSpiderTimeline x => Align (Event x) where
1161instance HasSpiderTimeline x => Align (Event x) where
1135 nil = eventNever
1162 nil = eventNever
1163+#if MIN_VERSION_these(0, 8, 0)
1164+instance HasSpiderTimeline x => Semialign (Event x) where
1166+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1136− align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1167+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1169+#ifdef MIN_VERSION_semialign
1170+#if MIN_VERSION_semialign(1,1,0)
1171+instance HasSpiderTimeline x => Zip (Event x) where
1173+ zip x y = mapMaybe justThese $ align x y
1138data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1176data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1139 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1177 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1140 | HoldDyn !(Hold x p)
1178 | HoldDyn !(Hold x p)
1142−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1180+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1144−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1182+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1145newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1183newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1147--TODO: Avoid the duplication between this and R.zipDynWith
1185--TODO: Avoid the duplication between this and R.zipDynWith
1148−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1186+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1149zipDynWith f da db =
1187zipDynWith f da db =
1150 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1188 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1151 ec = flip push eab $ \o -> do
1189 ec = flip push eab $ \o -> do
@@ -1168,18 +1206,12 @@ buildDynamic readV0 v' = do
1168 return d
1206 return d
1170unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1208unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1171−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1209+unsafeBuildDynamic readV0 v' =
1172− where x = (readV0, v')
1210+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1174-- ResultM can read behaviors and events
1212-- ResultM can read behaviors and events
1175type ResultM = EventM
1213type ResultM = EventM
1177−{-# NOINLINE unsafeNewIORef #-}
1178−unsafeNewIORef :: a -> b -> IORef b
1179−unsafeNewIORef a b = unsafePerformIO $ do
1183instance HasSpiderTimeline x => Functor (Event x) where
1215instance HasSpiderTimeline x => Functor (Event x) where
1184 fmap f = push $ return . Just . f
1216 fmap f = push $ return . Just . f
@@ -1192,33 +1224,42 @@ push f e = cacheEvent (pushCheap f e)
1193{-# INLINABLE pull #-}
1225{-# INLINABLE pull #-}
1194pull :: BehaviorM x a -> Behavior x a
1226pull :: BehaviorM x a -> Behavior x a
1195−pull a = behaviorPull $ Pull
1227+pull a = unsafePerformIO $ do
1196− { pullCompute = a
1228+ ref <- newIORef Nothing
1197− , pullValue = unsafeNewIORef a Nothing
1198#ifdef DEBUG_NODEIDS
1229#ifdef DEBUG_NODEIDS
1199− , pullNodeId = unsafeNodeId a
1230+ nid <- newNodeId
1232+ pure $ behaviorPull $ Pull
1235+#ifdef DEBUG_NODEIDS
1203{-# INLINABLE switch #-}
1240{-# INLINABLE switch #-}
1204switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1241switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1242+switch a = unsafePerformIO $ do
1243+ ref <- newIORef Nothing
1205−switch a = eventSwitch $ Switch
1244+ pure $ eventSwitch $ Switch
1206− { switchParent = a
1245+ { switchParent = a
1207− , switchSubscribed = unsafeNewIORef a Nothing
1246+ , switchSubscribed = ref
1210coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1249coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1250+coincidence a = unsafePerformIO $ do
1251+ ref <- newIORef Nothing
1211−coincidence a = eventCoincidence $ Coincidence
1252+ pure $ eventCoincidence $ Coincidence
1212− { coincidenceParent = a
1253+ { coincidenceParent = a
1213− , coincidenceSubscribed = unsafeNewIORef a Nothing
1254+ , coincidenceSubscribed = ref
1216-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1257-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1217run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1258run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1218run roots after = do
1259run roots after = do
1219 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1260 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1220 let t = spiderTimeline :: SpiderTimelineEnv x
1261 let t = spiderTimeline :: SpiderTimelineEnv x
1221− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1262+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1222 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1263 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1223 occBefore <- liftIO $ do
1264 occBefore <- liftIO $ do
1224 occBefore <- readIORef occRef
1265 occBefore <- readIORef occRef
@@ -1256,11 +1297,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1256 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1297 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1259−data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1300+newtype Clear a = Clear (IORef (Maybe a))
1261−data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1302+newtype IntClear a = IntClear (IORef (IntMap a))
1263−data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1304+newtype RootClear k = RootClear (IORef (DMap k Identity))
1265data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1306data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
@@ -1282,9 +1323,9 @@ type WeakList a = [Weak a]
1282withIncreasedDepth :: CanTrace x m => m a -> m a
1323withIncreasedDepth :: CanTrace x m => m a -> m a
1283withIncreasedDepth a = do
1324withIncreasedDepth a = do
1284 spiderTimeline <- askSpiderTimelineEnv
1325 spiderTimeline <- askSpiderTimelineEnv
1285− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1326+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1286 result <- a
1327 result <- a
1287− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1328+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1288 return result
1329 return result
1290withIncreasedDepth :: m a -> m a
1331withIncreasedDepth :: m a -> m a
@@ -1311,7 +1352,7 @@ traceMWhen _ b getMessage = when b $ do
1311 message <- getMessage
1352 message <- getMessage
1312#ifdef DEBUG
1353#ifdef DEBUG
1313 spiderTimeline <- askSpiderTimelineEnv
1354 spiderTimeline <- askSpiderTimelineEnv
1314− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1355+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1316 let d = 0
1357 let d = 0
@@ -1352,25 +1393,25 @@ propagateSubscriberHold h a = do
1352data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1393data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1354runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1395runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1355−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1396+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1357askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1398askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1358askInvalidator = do
1399askInvalidator = do
1359− (!m, _) <- BehaviorM ask
1400+ (!m, _) <- ask
1360 case m of
1401 case m of
1361 Nothing -> return Nothing
1402 Nothing -> return Nothing
1362 Just (!wi, _) -> return $ Just wi
1403 Just (!wi, _) -> return $ Just wi
1364askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1405askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1365askParentsRef = do
1406askParentsRef = do
1366− (!m, _) <- BehaviorM ask
1407+ (!m, _) <- ask
1367 case m of
1408 case m of
1368 Nothing -> return Nothing
1409 Nothing -> return Nothing
1369 Just (_, !p) -> return $ Just p
1410 Just (_, !p) -> return $ Just p
1371askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1412askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1372askBehaviorHoldInits = do
1413askBehaviorHoldInits = do
1373− (_, !his) <- BehaviorM ask
1414+ (_, !his) <- ask
1374 return his
1415 return his
1376{-# INLINE getDynHold #-}
1417{-# INLINE getDynHold #-}
@@ -1415,6 +1456,9 @@ getRootSubscribed k r sub = do
1415 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1456 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1416 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1457 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1417 writeIORef uninitRef $! uninit
1458 writeIORef uninitRef $! uninit
1459+#ifdef DEBUG_NODEIDS
1418 let !subscribed = RootSubscribed
1462 let !subscribed = RootSubscribed
1419 { rootSubscribedKey = k
1463 { rootSubscribedKey = k
1420 , rootSubscribedCachedSubscribed = cached
1464 , rootSubscribedCachedSubscribed = cached
@@ -1423,7 +1467,7 @@ getRootSubscribed k r sub = do
1423 , rootSubscribedUninit = uninit
1467 , rootSubscribedUninit = uninit
1424 , rootSubscribedWeakSelf = weakSelf
1468 , rootSubscribedWeakSelf = weakSelf
1425#ifdef DEBUG_NODEIDS
1469#ifdef DEBUG_NODEIDS
1426− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1470+ , rootSubscribedNodeId = nid
1429 -- If we die at the same moment that all our children die, they will
1473 -- If we die at the same moment that all our children die, they will
@@ -1472,16 +1516,10 @@ newFanInt = do
1472 , _fanInt_occRef = occRef
1516 , _fanInt_occRef = occRef
1475−{-# NOINLINE unsafeNewFanInt #-}
1476−unsafeNewFanInt :: b -> FanInt x a
1477−unsafeNewFanInt b = unsafePerformIO $ do
1481fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1519fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1482−fanInt p =
1520+fanInt p = unsafePerformIO $ do
1483− let self = unsafeNewFanInt p
1521+ self <- newFanInt
1484− in EventSelectorInt $ \k -> Event $ \sub -> do
1522+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1485 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1523 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1486 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1524 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1487 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1525 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1489,15 +1527,15 @@ fanInt p =
1489 liftIO $ writeIORef (_fanInt_occRef self) m
1527 liftIO $ writeIORef (_fanInt_occRef self) m
1490 scheduleIntClear $ _fanInt_occRef self
1528 scheduleIntClear $ _fanInt_occRef self
1491 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1529 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1492− FastWeakBag.traverse b $ \s -> do
1530+ FastWeakBag.traverse_ b $ \s -> do
1493 subscriberPropagate s v
1531 subscriberPropagate s v
1494 , subscriberInvalidateHeight = \old -> do
1532 , subscriberInvalidateHeight = \old -> do
1495 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1533 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1496− FastWeakBag.traverse b $ \s -> do
1534+ FastWeakBag.traverse_ b $ \s -> do
1497 subscriberInvalidateHeight s old
1535 subscriberInvalidateHeight s old
1498 , subscriberRecalculateHeight = \new -> do
1536 , subscriberRecalculateHeight = \new -> do
1499 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1537 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1500− FastWeakBag.traverse b $ \s -> do
1538+ FastWeakBag.traverse_ b $ \s -> do
1501 subscriberRecalculateHeight s new
1539 subscriberRecalculateHeight s new
1503 liftIO $ do
1541 liftIO $ do
@@ -1517,7 +1555,7 @@ fanInt p =
1517 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1555 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1519{-# INLINABLE getFanSubscribed #-}
1557{-# INLINABLE getFanSubscribed #-}
1520−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1558+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1521getFanSubscribed k f sub = do
1559getFanSubscribed k f sub = do
1522 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1560 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1523 case mSubscribed of
1561 case mSubscribed of
@@ -1535,13 +1573,16 @@ getFanSubscribed k f sub = do
1535 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1573 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1536 occRef <- liftIO $ newIORef parentOcc
1574 occRef <- liftIO $ newIORef parentOcc
1537 when (isJust parentOcc) $ scheduleClear occRef
1575 when (isJust parentOcc) $ scheduleClear occRef
1576+#ifdef DEBUG_NODEIDS
1577+ nid <- liftIO newNodeId
1538 let subscribed = FanSubscribed
1579 let subscribed = FanSubscribed
1539 { fanSubscribedCachedSubscribed = fanSubscribed f
1580 { fanSubscribedCachedSubscribed = fanSubscribed f
1540 , fanSubscribedOccurrence = occRef
1581 , fanSubscribedOccurrence = occRef
1541 , fanSubscribedParent = subscription
1582 , fanSubscribedParent = subscription
1542 , fanSubscribedSubscribers = subscribersRef
1583 , fanSubscribedSubscribers = subscribersRef
1543#ifdef DEBUG_NODEIDS
1584#ifdef DEBUG_NODEIDS
1544− , fanSubscribedNodeId = unsafeNodeId f
1585+ , fanSubscribedNodeId = nid
1547 let !self = (k, subscribed)
1588 let !self = (k, subscribed)
@@ -1551,7 +1592,7 @@ getFanSubscribed k f sub = do
1551 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1592 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1552 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1593 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1554−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1595+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1555cleanupFanSubscribed (k, subscribed) = do
1596cleanupFanSubscribed (k, subscribed) = do
1556 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1597 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1557 let reducedSubscribers = DMap.delete k subscribers
1598 let reducedSubscribers = DMap.delete k subscribers
@@ -1563,7 +1604,7 @@ cleanupFanSubscribed (k, subscribed) = do
1563 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1604 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1565{-# INLINE subscribeFanSubscribed #-}
1606{-# INLINE subscribeFanSubscribed #-}
1566−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1607+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1567subscribeFanSubscribed k subscribed sub = do
1608subscribeFanSubscribed k subscribed sub = do
1568 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1609 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1569 case DMap.lookup k subscribers of
1610 case DMap.lookup k subscribers of
@@ -1601,6 +1642,9 @@ getSwitchSubscribed s sub = do
1601 when (isJust parentOcc) $ scheduleClear occRef
1642 when (isJust parentOcc) $ scheduleClear occRef
1602 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1643 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1603 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1644 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1645+#ifdef DEBUG_NODEIDS
1646+ nid <- liftIO newNodeId
1604 let !subscribed = SwitchSubscribed
1648 let !subscribed = SwitchSubscribed
1605 { switchSubscribedCachedSubscribed = switchSubscribed s
1649 { switchSubscribedCachedSubscribed = switchSubscribed s
1606 , switchSubscribedOccurrence = occRef
1650 , switchSubscribedOccurrence = occRef
@@ -1613,7 +1657,7 @@ getSwitchSubscribed s sub = do
1613 , switchSubscribedCurrentParent = subscriptionRef
1657 , switchSubscribedCurrentParent = subscriptionRef
1614 , switchSubscribedWeakSelf = weakSelf
1658 , switchSubscribedWeakSelf = weakSelf
1615#ifdef DEBUG_NODEIDS
1659#ifdef DEBUG_NODEIDS
1616− , switchSubscribedNodeId = unsafeNodeId s
1660+ , switchSubscribedNodeId = nid
1619 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1663 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1658,6 +1702,9 @@ getCoincidenceSubscribed c sub = do
1658 scheduleClear innerSubdRef
1702 scheduleClear innerSubdRef
1659 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1703 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1660 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1704 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1705+#ifdef DEBUG_NODEIDS
1706+ nid <- liftIO newNodeId
1661 let subscribed = CoincidenceSubscribed
1708 let subscribed = CoincidenceSubscribed
1662 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1709 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1663 , coincidenceSubscribedOccurrence = occRef
1710 , coincidenceSubscribedOccurrence = occRef
@@ -1668,7 +1715,7 @@ getCoincidenceSubscribed c sub = do
1668 , coincidenceSubscribedInnerParent = innerSubdRef
1715 , coincidenceSubscribedInnerParent = innerSubdRef
1669 , coincidenceSubscribedWeakSelf = weakSelf
1716 , coincidenceSubscribedWeakSelf = weakSelf
1670#ifdef DEBUG_NODEIDS
1717#ifdef DEBUG_NODEIDS
1671− , coincidenceSubscribedNodeId = unsafeNodeId c
1718+ , coincidenceSubscribedNodeId = nid
1674 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1721 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1685,26 +1732,34 @@ cleanupCoincidenceSubscribed subscribed = do
1685subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1732subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1686subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1733subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1688−{-# INLINE merge #-}
1735+{-# INLINE mergeG #-}
1689−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1736+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1737+ => (forall a. q a -> Event x (v a))
1738+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1690−merge d = cacheEvent (mergeCheap d)
1739+mergeG nt d = cacheEvent (mergeCheap nt d)
1692{-# INLINE mergeWithMove #-}
1741{-# INLINE mergeWithMove #-}
1693−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1742+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1743+ => (forall a. q a -> Event x (v a))
1744+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1694−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1745+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1696{-# INLINE [1] mergeCheap #-}
1747{-# INLINE [1] mergeCheap #-}
1697−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1749+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1750+ => (forall a. q a -> Event x (v a))
1751+ -> DynamicS x (PatchDMap k q)
1752+ -> Event x (DMap k v)
1698−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1753+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1700− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1755+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1701 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1756 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1702 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1757 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1703 (mOldSubd, newPs) <- case me of
1758 (mOldSubd, newPs) <- case me of
1704 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1759 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1705 Just e -> do
1760 Just e -> do
1706 let s = subscriber $ return k
1761 let s = subscriber $ return k
1707− subscription@(EventSubscription _ subd) <- subscribe e s
1762+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1708 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1763 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1709 let newParent = MergeSubscribedParent subscription
1764 let newParent = MergeSubscribedParent subscription
1710 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1765 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1714,28 +1769,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1714 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1769 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1715 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1770 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1716 foldM f ([], oldParents) $ DMap.toList p
1771 foldM f ([], oldParents) $ DMap.toList p
1717− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1773+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1718 getInitialSubscribers initialParents subscriber = do
1774 getInitialSubscribers initialParents subscriber = do
1719 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1775 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1720 let s = subscriber $ return k
1776 let s = subscriber $ return k
1721− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1777+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1722 height <- liftIO $ getEventSubscribedHeight parentSubd
1778 height <- liftIO $ getEventSubscribedHeight parentSubd
1723− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1779+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1724 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1780 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1725 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1781 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1726 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1782 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1728 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1785 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1729 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1786 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1731{-# INLINE [1] mergeCheapWithMove #-}
1788{-# INLINE [1] mergeCheapWithMove #-}
1732−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1789+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1790+ => (forall a. q a -> Event x (v a))
1791+ -> DynamicS x (PatchDMapWithMove k q)
1792+ -> Event x (DMap k v)
1733−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1793+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1735− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1795+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1736 updateMe subscriber heightBagRef oldParents p = do
1796 updateMe subscriber heightBagRef oldParents p = do
1737 -- Prepare new parents for insertion
1797 -- Prepare new parents for insertion
1738− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1798+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1739 subscribeParent k e = do
1799 subscribeParent k e = do
1740 keyRef <- liftIO $ newIORef k
1800 keyRef <- liftIO $ newIORef k
1741 let s = subscriber $ liftIO $ readIORef keyRef
1801 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1744,9 +1804,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1744 newParentHeight <- getEventSubscribedHeight subd
1804 newParentHeight <- getEventSubscribedHeight subd
1745 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1805 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1746 return $ MergeSubscribedParentWithMove subscription keyRef
1806 return $ MergeSubscribedParentWithMove subscription keyRef
1747− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1807+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1748 -- Collect old parents for deletion and update the keys of moved parents
1808 -- Collect old parents for deletion and update the keys of moved parents
1749− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1809+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1750 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1810 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1751 Nothing -> do
1811 Nothing -> do
1752 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1812 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1757,46 +1817,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1757 return Nothing
1817 return Nothing
1758 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1818 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1759 return (toDelete, applyAlways p' oldParents)
1819 return (toDelete, applyAlways p' oldParents)
1760− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1820+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1761 getInitialSubscribers initialParents subscriber = do
1821 getInitialSubscribers initialParents subscriber = do
1762 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1822 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1763 keyRef <- liftIO $ newIORef k
1823 keyRef <- liftIO $ newIORef k
1764 let s = subscriber $ liftIO $ readIORef keyRef
1824 let s = subscriber $ liftIO $ readIORef keyRef
1765− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1825+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1766 height <- liftIO $ getEventSubscribedHeight parentSubd
1826 height <- liftIO $ getEventSubscribedHeight parentSubd
1767− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1827+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1768 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1828 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1769 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1829 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1770 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1830 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1772 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1833 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1773 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1834 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1775−type MergeUpdateFunc k x p s
1836+type MergeUpdateFunc k v x p s
1776− = (forall a. EventM x (k a) -> Subscriber x a)
1837+ = (forall a. EventM x (k a) -> Subscriber x (v a))
1777 -> IORef HeightBag
1838 -> IORef HeightBag
1778 -> DMap k s
1839 -> DMap k s
1780 -> EventM x ([EventSubscription x], DMap k s)
1841 -> EventM x ([EventSubscription x], DMap k s)
1782−type MergeInitFunc k x s
1843+type MergeInitFunc k v q x s
1783− = DMap k (Event x)
1844+ = DMap k q
1784− -> (forall a. EventM x (k a) -> Subscriber x a)
1845+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1785− -> EventM x (DMap k Identity, [Height], DMap k s)
1846+ -> EventM x (DMap k v, [Height], DMap k s)
1787type MergeDestroyFunc k s
1848type MergeDestroyFunc k s
1788 = DMap k s
1849 = DMap k s
1789 -> IO ()
1850 -> IO ()
1791−data Merge x k s = Merge
1852+data Merge x k v s = Merge
1792 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1853 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1793 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1854 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1794 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1855 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1795− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1856+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1796− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1857+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1799−invalidateMergeHeight :: Merge x k s -> IO ()
1860+invalidateMergeHeight :: Merge x k v s -> IO ()
1800invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1861invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1802invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1863invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1806,8 +1867,7 @@ invalidateMergeHeight' heightRef sub = do
1806 writeIORef heightRef $! invalidHeight
1867 writeIORef heightRef $! invalidHeight
1807 subscriberInvalidateHeight sub oldHeight
1868 subscriberInvalidateHeight sub oldHeight
1810−revalidateMergeHeight :: Merge x k s -> IO ()
1870+revalidateMergeHeight :: Merge x k v s -> IO ()
1811revalidateMergeHeight m = do
1871revalidateMergeHeight m = do
1812 currentHeight <- readIORef $ _merge_heightRef m
1872 currentHeight <- readIORef $ _merge_heightRef m
1813 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1873 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1823,19 +1883,19 @@ revalidateMergeHeight m = do
1823 subscriberRecalculateHeight (_merge_sub m) height
1883 subscriberRecalculateHeight (_merge_sub m) height
1824 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1884 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1826−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1886+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1827scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1887scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1828 vals <- liftIO $ readIORef $ _merge_accumRef m
1888 vals <- liftIO $ readIORef $ _merge_accumRef m
1829 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1889 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1830 --TODO: Assert that m is not empty
1890 --TODO: Assert that m is not empty
1831 subscriberPropagate (_merge_sub m) vals
1891 subscriberPropagate (_merge_sub m) vals
1833−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1893+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1834mergeSubscriber m getKey = Subscriber
1894mergeSubscriber m getKey = Subscriber
1835 { subscriberPropagate = \a -> do
1895 { subscriberPropagate = \a -> do
1836 oldM <- liftIO $ readIORef $ _merge_accumRef m
1896 oldM <- liftIO $ readIORef $ _merge_accumRef m
1837 k <- getKey
1897 k <- getKey
1838− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1898+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1839 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1899 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1840 liftIO $ writeIORef (_merge_accumRef m) $! newM
1900 liftIO $ writeIORef (_merge_accumRef m) $! newM
1841 when (DMap.null oldM) $ do -- Only schedule the firing once
1901 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1850,7 +1910,7 @@ mergeSubscriber m getKey = Subscriber
1850 else liftIO $ do
1910 else liftIO $ do
1851#ifdef DEBUG_CYCLES
1911#ifdef DEBUG_CYCLES
1852 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1912 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1853− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1913+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1854 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1914 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1856 let cycleInfo = ""
1916 let cycleInfo = ""
@@ -1866,7 +1926,7 @@ mergeSubscriber m getKey = Subscriber
1868--TODO: Be able to run as much of this as possible promptly
1928--TODO: Be able to run as much of this as possible promptly
1869−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1929+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1870updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1930updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1871 where updateMe = do
1931 where updateMe = do
1872 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1932 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1874,9 +1934,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1874 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1934 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1875 return subscriptionsToKill
1935 return subscriptionsToKill
1877−{-# INLINE mergeCheap' #-}
1937+{-# INLINE mergeGCheap' #-}
1938+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1878−mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)
1939+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1879−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1940+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1880 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1941 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1881 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1942 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1882 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1943 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1924,11 +1985,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1927−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1988+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1928mergeInt = cacheEvent . mergeIntCheap
1989mergeInt = cacheEvent . mergeIntCheap
1930{-# INLINABLE mergeIntCheap #-}
1991{-# INLINABLE mergeIntCheap #-}
1931−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1992+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1932mergeIntCheap d = Event $ \sub -> do
1993mergeIntCheap d = Event $ \sub -> do
1933 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1994 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1934 accum <- liftIO $ FastMutableIntMap.newEmpty
1995 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2025,14 +2086,16 @@ mergeIntCheap d = Event $ \sub -> do
2027newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2088newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2089+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2029−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2091+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2030−fan e =
2092+fanG e = unsafePerformIO $ do
2093+ ref <- newIORef Nothing
2031 let f = Fan
2094 let f = Fan
2032 { fanParent = e
2095 { fanParent = e
2033− , fanSubscribed = unsafeNewIORef e Nothing
2096+ , fanSubscribed = ref
2035− in EventSelector $ \k -> eventFan k f
2098+ pure $ EventSelectorG $ \k -> eventFan k f
2037runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2100runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2038runHoldInits holdInitRef dynInitRef mergeInitRef = do
2101runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2086,18 +2149,18 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2086-- | Run an event action outside of a frame
2149-- | Run an event action outside of a frame
2087runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2150runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2088runFrame a = SpiderHost $ do
2151runFrame a = SpiderHost $ do
2089− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2152+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2090 let go = do
2153 let go = do
2091 result <- a
2154 result <- a
2092 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2155 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2093 return result
2156 return result
2094 result <- runEventM go
2157 result <- runEventM go
2095 toClear <- readIORef $ eventEnvClears env
2158 toClear <- readIORef $ eventEnvClears env
2096− forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2159+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2097 toClearInt <- readIORef $ eventEnvIntClears env
2160 toClearInt <- readIORef $ eventEnvIntClears env
2098− forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2161+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2099 toClearRoot <- readIORef $ eventEnvRootClears env
2162 toClearRoot <- readIORef $ eventEnvRootClears env
2100− forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2163+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2101 toAssign <- readIORef $ eventEnvAssignments env
2164 toAssign <- readIORef $ eventEnvAssignments env
2102 toReconnectRef <- newIORef []
2165 toReconnectRef <- newIORef []
2103 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2166 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
@@ -2144,7 +2207,7 @@ runFrame a = SpiderHost $ do
2144 myHeight <- readIORef $ switchSubscribedHeight subscribed
2207 myHeight <- readIORef $ switchSubscribedHeight subscribed
2145 when (parentHeight /= myHeight) $ do
2208 when (parentHeight /= myHeight) $ do
2146 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2209 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2147− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2210+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2148 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --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
2211 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --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
2149 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2212 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2150 unsubscribe subscription
2213 unsubscribe subscription
@@ -2185,7 +2248,7 @@ invalidateCoincidenceHeight subscribed = do
2185 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2248 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2186 when (oldHeight /= invalidHeight) $ do
2249 when (oldHeight /= invalidHeight) $ do
2187 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2250 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2188− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2251+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2190updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2253updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2191updateSwitchHeight new subscribed = do
2254updateSwitchHeight new subscribed = do
@@ -2193,7 +2256,7 @@ updateSwitchHeight new subscribed = do
2193 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2256 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2194 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2257 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2195 writeIORef (switchSubscribedHeight subscribed) $! new
2258 writeIORef (switchSubscribedHeight subscribed) $! new
2196− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2259+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2198recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2261recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2199recalculateCoincidenceHeight subscribed = do
2262recalculateCoincidenceHeight subscribed = do
@@ -2202,7 +2265,7 @@ recalculateCoincidenceHeight subscribed = do
2202 height <- calculateCoincidenceHeight subscribed
2265 height <- calculateCoincidenceHeight subscribed
2203 when (height /= invalidHeight) $ do
2266 when (height /= invalidHeight) $ do
2204 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2267 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2205− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2268+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2207calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2270calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2208calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2271calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2297,7 +2360,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2297 fail _ = error "Dynamic does not support 'fail'"
2360 fail _ = error "Dynamic does not support 'fail'"
2299{-# INLINABLE newJoinDyn #-}
2362{-# INLINABLE newJoinDyn #-}
2300−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2363+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2301newJoinDyn d =
2364newJoinDyn d =
2302 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2365 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2303 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2366 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2307,9 +2370,13 @@ newJoinDyn d =
2307 in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2370 in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2309instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2372instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2310− fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2373+ fmap = mapDynamicSpider
2311 x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2374 x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2376+mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b
2377+mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2378+{-# INLINE [1] mapDynamicSpider #-}
2313instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2380instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2314 pure = SpiderDynamic . dynamicConst
2381 pure = SpiderDynamic . dynamicConst
2315#if MIN_VERSION_base(4,10,0)
2382#if MIN_VERSION_base(4,10,0)
@@ -2443,7 +2510,7 @@ unsafeNewSpiderTimelineEnv = do
2443#ifdef DEBUG
2510#ifdef DEBUG
2444 depthRef <- newIORef 0
2511 depthRef <- newIORef 0
2446− return $ SpiderTimelineEnv
2513+ return $ STE $ SpiderTimelineEnv
2447 { _spiderTimeline_lock = lock
2514 { _spiderTimeline_lock = lock
2448 , _spiderTimeline_eventEnv = env
2515 , _spiderTimeline_eventEnv = env
2449#ifdef DEBUG
2516#ifdef DEBUG
@@ -2453,19 +2520,19 @@ unsafeNewSpiderTimelineEnv = do
2454-- | Create a new SpiderTimelineEnv
2521-- | Create a new SpiderTimelineEnv
2455newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2522newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2456−newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2523+newSpiderTimeline = withSpiderTimeline (pure . Some)
2458−data LocalSpiderTimeline x s
2525+data LocalSpiderTimeline (x :: Type) s
2460instance Reifies s (SpiderTimelineEnv x) =>
2527instance Reifies s (SpiderTimelineEnv x) =>
2461 HasSpiderTimeline (LocalSpiderTimeline x s) where
2528 HasSpiderTimeline (LocalSpiderTimeline x s) where
2462− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2529+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2464localSpiderTimeline
2531localSpiderTimeline
2465− :: Proxy s
2532+ :: proxy s
2466 -> SpiderTimelineEnv x
2533 -> SpiderTimelineEnv x
2467 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2534 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2468−localSpiderTimeline _ = unsafeCoerce
2535+localSpiderTimeline _ = coerce
2470-- | Pass a new timeline to the given function.
2537-- | Pass a new timeline to the given function.
2471withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2538withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2473,18 +2540,18 @@ withSpiderTimeline k = do
2473 env <- unsafeNewSpiderTimelineEnv
2540 env <- unsafeNewSpiderTimelineEnv
2474 reify env $ \s -> k $ localSpiderTimeline s env
2541 reify env $ \s -> k $ localSpiderTimeline s env
2476−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2543+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2478type ComputeM = EventM
2545type ComputeM = EventM
2480−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2547+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2482instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2549instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2483 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2550 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2484 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2551 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2485 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2552 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2486− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2553+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2487− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2554+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2488 type PullM (SpiderTimeline x) = SpiderPullM x
2555 type PullM (SpiderTimeline x) = SpiderPullM x
2489 type PushM (SpiderTimeline x) = SpiderPushM x
2556 type PushM (SpiderTimeline x) = SpiderPushM x
2490 {-# INLINABLE never #-}
2557 {-# INLINABLE never #-}
@@ -2497,10 +2564,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2497 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2564 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2498 {-# INLINABLE pull #-}
2565 {-# INLINABLE pull #-}
2499 pull = SpiderBehavior . pull . coerce
2566 pull = SpiderBehavior . pull . coerce
2500− {-# INLINABLE merge #-}
2567+ {-# INLINABLE fanG #-}
2501− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2502− {-# INLINABLE fan #-}
2503− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2568+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2569+ {-# INLINABLE mergeG #-}
2571+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2572+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2574+ -> R.Event (SpiderTimeline x) (DMap k v)
2575+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2504 {-# INLINABLE switch #-}
2576 {-# INLINABLE switch #-}
2505 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2577 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2506 {-# INLINABLE coincidence #-}
2578 {-# INLINABLE coincidence #-}
@@ -2508,15 +2580,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2508 {-# INLINABLE current #-}
2580 {-# INLINABLE current #-}
2509 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2581 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2510 {-# INLINABLE updated #-}
2582 {-# INLINABLE updated #-}
2511− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2583+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2512 {-# INLINABLE unsafeBuildDynamic #-}
2584 {-# INLINABLE unsafeBuildDynamic #-}
2513 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2585 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2514 {-# INLINABLE unsafeBuildIncremental #-}
2586 {-# INLINABLE unsafeBuildIncremental #-}
2515 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2587 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2516− {-# INLINABLE mergeIncremental #-}
2588+ {-# INLINABLE mergeIncrementalG #-}
2517− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2589+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2518− {-# INLINABLE mergeIncrementalWithMove #-}
2590+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2519− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2591+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2520 {-# INLINABLE currentIncremental #-}
2592 {-# INLINABLE currentIncremental #-}
2521 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2593 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2522 {-# INLINABLE updatedIncremental #-}
2594 {-# INLINABLE updatedIncremental #-}
@@ -2527,9 +2599,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2527 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2599 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2528 eventCoercion Coercion = Coercion
2600 eventCoercion Coercion = Coercion
2529 behaviorCoercion Coercion = Coercion
2601 behaviorCoercion Coercion = Coercion
2530− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2602+ dynamicCoercion Coercion = Coercion
2603+ incrementalCoercion Coercion Coercion = Coercion
2531 {-# INLINABLE mergeIntIncremental #-}
2604 {-# INLINABLE mergeIntIncremental #-}
2532− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2605+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
2533 {-# INLINABLE fanInt #-}
2606 {-# INLINABLE fanInt #-}
2534 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2607 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
@@ -2554,7 +2627,7 @@ instance MonadAtomicRef (EventM x) where
2554 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2627 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2556-- | The monad for actions that manipulate a Spider timeline identified by @x@
2629-- | The monad for actions that manipulate a Spider timeline identified by @x@
2557−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2630+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2559instance Monad (SpiderHost x) where
2632instance Monad (SpiderHost x) where
2560 {-# INLINABLE (>>=) #-}
2633 {-# INLINABLE (>>=) #-}
@@ -2576,7 +2649,7 @@ runSpiderHost (SpiderHost a) = a
2576runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2649runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2577runSpiderHostForTimeline (SpiderHost a) _ = a
2650runSpiderHostForTimeline (SpiderHost a) _ = a
2579−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2652+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2580 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2653 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2582instance Monad (SpiderHostFrame x) where
2655instance Monad (SpiderHostFrame x) where