@@ -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,6 +57,7 @@ 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
60+import Data.Kind (Type)
52import Data.Maybe hiding (mapMaybe)
61import Data.Maybe hiding (mapMaybe)
53import Data.Monoid ((<>))
62import Data.Monoid ((<>))
54import Data.Proxy
63import Data.Proxy
@@ -63,6 +72,12 @@ import System.IO.Unsafe
63import System.Mem.Weak
72import System.Mem.Weak
64import Unsafe.Coerce
73import Unsafe.Coerce
75+#if defined(MIN_VERSION_semialign)
76+#if MIN_VERSION_these(0,8,0)
77+import Data.These.Combinators (justThese)
66#ifdef DEBUG_CYCLES
81#ifdef DEBUG_CYCLES
67import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
82import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
68import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
83import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
@@ -74,9 +89,9 @@ import Data.Tree (Forest, Tree (..), drawForest)
74import Data.FastWeakBag (FastWeakBag)
89import Data.FastWeakBag (FastWeakBag)
75import qualified Data.FastWeakBag as FastWeakBag
90import qualified Data.FastWeakBag as FastWeakBag
76import Data.Reflection
91import Data.Reflection
77−import Data.Some (Some)
92+import Data.Some (Some(Some))
78−import qualified Data.Some as Some
79import Data.Type.Coercion
93import Data.Type.Coercion
94+import Data.Profunctor.Unsafe ((#.), (.#))
80import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
95import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
81import qualified Data.WeakBag as WeakBag
96import qualified Data.WeakBag as WeakBag
82import qualified Reflex.Class
97import qualified Reflex.Class
@@ -193,12 +208,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
194newNodeId :: IO Int
209newNodeId :: IO Int
195newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
210newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
197−{-# NOINLINE unsafeNodeId #-}
198−unsafeNodeId :: a -> Int
199−unsafeNodeId a = unsafePerformIO $ do
204--------------------------------------------------------------------------------
213--------------------------------------------------------------------------------
@@ -302,9 +311,10 @@ cacheEvent e =
314+ unsafePerformIO $ do
305− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
315+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
316+ <- newIORef emptyFastWeak
307− in \sub -> {-# SCC "cacheEvent" #-} do
317+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
308#ifdef DEBUG_TRACE_EVENTS
318#ifdef DEBUG_TRACE_EVENTS
309 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
319 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
@@ -370,7 +380,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
370eventNever :: Event x a
380eventNever :: Event x a
371eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
381eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
373−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
383+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
374eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
384eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
376eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
386eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -422,14 +432,14 @@ newSubscriberHold h = return $ Subscriber
422 , subscriberRecalculateHeight = \_ -> return ()
432 , subscriberRecalculateHeight = \_ -> return ()
425−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
435+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
426newSubscriberFan subscribed = return $ Subscriber
436newSubscriberFan subscribed = return $ Subscriber
427 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
437 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
428 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
438 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"
439 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
440 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
431 scheduleClear $ fanSubscribedOccurrence subscribed
441 scheduleClear $ fanSubscribedOccurrence subscribed
432− let f _ (Pair (Identity v) subsubs) = do
442+ let f _ (Pair v subsubs) = do
433 propagate v $ _fanSubscribedChildren_list subsubs
443 propagate v $ _fanSubscribedChildren_list subsubs
434 return $ Constant ()
444 return $ Constant ()
435 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
445 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -545,6 +555,11 @@ propagateFast a subscribers = withIncreasedDepth $ do
545toAny :: a -> Any
555toAny :: a -> Any
546toAny = unsafeCoerce
556toAny = unsafeCoerce
558+-- Why do we use Any here, instead of just giving eventSubscribedRetained an
559+-- existential type? Sadly, GHC does not currently know how to unbox types
560+-- with existentially quantified fields. So instead we just coerce values
561+-- to type Any on the way in. Since we never coerce them back, this is
548data EventSubscribed x = EventSubscribed
563data EventSubscribed x = EventSubscribed
549 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
564 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
550 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
565 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -577,12 +592,12 @@ eventSubscribedNever = EventSubscribed
580−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
595+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
581eventSubscribedFan !subscribed = EventSubscribed
596eventSubscribedFan !subscribed = EventSubscribed
582 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
597 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
583 , eventSubscribedRetained = toAny subscribed
598 , eventSubscribedRetained = toAny subscribed
584#ifdef DEBUG_CYCLES
599#ifdef DEBUG_CYCLES
585− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
600+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
586 , eventSubscribedHasOwnHeightRef = False
601 , eventSubscribedHasOwnHeightRef = False
587 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
602 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
@@ -595,7 +610,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
595#ifdef DEBUG_CYCLES
610#ifdef DEBUG_CYCLES
596 , eventSubscribedGetParents = do
611 , eventSubscribedGetParents = do
597 s <- readIORef $ switchSubscribedCurrentParent subscribed
612 s <- readIORef $ switchSubscribedCurrentParent subscribed
598− return [Some.This $ _eventSubscription_subscribed s]
613+ return [Some $ _eventSubscription_subscribed s]
599 , eventSubscribedHasOwnHeightRef = True
614 , eventSubscribedHasOwnHeightRef = True
600 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
615 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
@@ -608,8 +623,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
608#ifdef DEBUG_CYCLES
623#ifdef DEBUG_CYCLES
609 , eventSubscribedGetParents = do
624 , eventSubscribedGetParents = do
610 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
625 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
611− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
626+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612− innerParents = maybeToList $ fmap Some.This innerSubscription
627+ innerParents = maybeToList $ fmap Some innerSubscription
613 return $ outerParent : innerParents
628 return $ outerParent : innerParents
614 , eventSubscribedHasOwnHeightRef = True
629 , eventSubscribedHasOwnHeightRef = True
615 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
630 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -625,13 +640,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated
626walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
641walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
627walkInvalidHeightParents s0 = do
642walkInvalidHeightParents s0 = do
628− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
643+ subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
629 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
644 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
630 when (h == invalidHeight) $ do
645 when (h == invalidHeight) $ do
631 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
646 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
632− modify (Some.This s :)
647+ modify (Some s :)
633 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
648 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
634− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
649+ forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
635 return subscribers
650 return subscribers
@@ -659,7 +674,7 @@ behaviorPull !p = Behavior $ do
659 val <- liftIO $ readIORef $ pullValue p
674 val <- liftIO $ readIORef $ pullValue p
660 case val of
675 case val of
661 Just subscribed -> do
676 Just subscribed -> do
662− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))
677+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
663 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
678 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
664 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
679 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
665 return $ pullSubscribedValue subscribed
680 return $ pullSubscribedValue subscribed
@@ -668,7 +683,7 @@ behaviorPull !p = Behavior $ do
668 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
683 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
669 parentsRef <- liftIO $ newIORef []
684 parentsRef <- liftIO $ newIORef []
670 holdInits <- askBehaviorHoldInits
685 holdInits <- askBehaviorHoldInits
671− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
686+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
672 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
687 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
673 parents <- liftIO $ readIORef parentsRef
688 parents <- liftIO $ readIORef parentsRef
674 let subscribed = PullSubscribed
689 let subscribed = PullSubscribed
@@ -678,7 +693,7 @@ behaviorPull !p = Behavior $ do
678 , pullSubscribedParents = parents
693 , pullSubscribedParents = parents
680 liftIO $ writeIORef (pullValue p) $ Just subscribed
695 liftIO $ writeIORef (pullValue p) $ Just subscribed
681− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))
696+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
684behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
699behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
@@ -689,7 +704,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
689readHoldTracked h = do
704readHoldTracked h = do
690 result <- liftIO $ readIORef $ holdValue h
705 result <- liftIO $ readIORef $ holdValue h
691 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
706 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
692− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedHold h)) :))
707+ 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
708 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
694 return result
709 return result
@@ -703,42 +718,46 @@ readBehaviorUntracked b = do
703-- Dynamic
718-- Dynamic
704--------------------------------------------------------------------------------
719--------------------------------------------------------------------------------
721+type DynamicS x p = Dynamic x (PatchTarget p) p
706−data Dynamic x p = Dynamic
723+data Dynamic x target p = Dynamic
707− { dynamicCurrent :: !(Behavior x (PatchTarget p))
724+ { dynamicCurrent :: !(Behavior x target)
708 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
725 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
728+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
711−dynamicHold :: Hold x p -> Dynamic x p
733+dynamicHold :: Hold x p -> DynamicS x p
712dynamicHold !h = Dynamic
734dynamicHold !h = Dynamic
713 { dynamicCurrent = behaviorHold h
735 { dynamicCurrent = behaviorHold h
714 , dynamicUpdated = eventHold h
736 , dynamicUpdated = eventHold h
717−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
739+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
718dynamicHoldIdentity = dynamicHold
740dynamicHoldIdentity = dynamicHold
720−dynamicConst :: PatchTarget p -> Dynamic x p
742+dynamicConst :: PatchTarget p -> DynamicS x p
721dynamicConst !a = Dynamic
743dynamicConst !a = Dynamic
722 { dynamicCurrent = behaviorConst a
744 { dynamicCurrent = behaviorConst a
723 , dynamicUpdated = eventNever
745 , dynamicUpdated = eventNever
726−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
748+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
727dynamicDyn !d = Dynamic
749dynamicDyn !d = Dynamic
728 { dynamicCurrent = behaviorDyn d
750 { dynamicCurrent = behaviorDyn d
729 , dynamicUpdated = eventDyn d
751 , dynamicUpdated = eventDyn d
732−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
754+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
733dynamicDynIdentity = dynamicDyn
755dynamicDynIdentity = dynamicDyn
735--------------------------------------------------------------------------------
757--------------------------------------------------------------------------------
736-- Combinators
758-- Combinators
737--------------------------------------------------------------------------------
759--------------------------------------------------------------------------------
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
761--type role Hold representational
743data Hold x p
762data Hold x p
744 = Hold { holdValue :: !(IORef (PatchTarget p))
763 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -759,20 +778,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
760-- | Stores all global data relevant to a particular Spider timeline; only one
779-- | Stores all global data relevant to a particular Spider timeline; only one
761-- value should exist for each type @x@
780-- value should exist for each type @x@
781+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
782+-- We implement SpiderTimelineEnv with a newtype wrapper so
783+-- we can get the coercions we want safely.
784+type role SpiderTimelineEnv nominal
762−data SpiderTimelineEnv x = SpiderTimelineEnv
786+data SpiderTimelineEnv' x = SpiderTimelineEnv
763 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
787 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
764 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
788 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
765#ifdef DEBUG
789#ifdef DEBUG
766 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
790 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
769−type role SpiderTimelineEnv nominal
793+type role SpiderTimelineEnv' phantom
771instance Eq (SpiderTimelineEnv x) where
795instance Eq (SpiderTimelineEnv x) where
772 _ == _ = True -- Since only one exists of each type
796 _ == _ = True -- Since only one exists of each type
774instance GEq SpiderTimelineEnv where
798instance GEq SpiderTimelineEnv where
775− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
799+ 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
800 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
777 else Nothing
801 else Nothing
@@ -795,7 +819,7 @@ runEventM :: EventM x a -> IO a
795runEventM = unEventM
819runEventM = unEventM
797asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
821asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
798−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
822+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
800class MonadIO m => Defer a m where
824class MonadIO m => Defer a m where
801 getDeferralQueue :: m (IORef [a])
825 getDeferralQueue :: m (IORef [a])
@@ -862,7 +886,7 @@ instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
863{-# INLINE scheduleClear #-}
887{-# INLINE scheduleClear #-}
864scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
888scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
865−scheduleClear r = defer $ Some.This $ Clear r
889+scheduleClear r = defer $ Some $ Clear r
867instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
891instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
868 {-# INLINE getDeferralQueue #-}
892 {-# INLINE getDeferralQueue #-}
@@ -870,7 +894,7 @@ instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
871{-# INLINE scheduleIntClear #-}
895{-# INLINE scheduleIntClear #-}
872scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
896scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
873−scheduleIntClear r = defer $ Some.This $ IntClear r
897+scheduleIntClear r = defer $ Some $ IntClear r
875instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
899instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
876 {-# INLINE getDeferralQueue #-}
900 {-# INLINE getDeferralQueue #-}
@@ -878,7 +902,7 @@ instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
879{-# INLINE scheduleRootClear #-}
903{-# INLINE scheduleRootClear #-}
880scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
904scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
881−scheduleRootClear r = defer $ Some.This $ RootClear r
905+scheduleRootClear r = defer $ Some $ RootClear r
883instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
907instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
884 {-# INLINE getDeferralQueue #-}
908 {-# INLINE getDeferralQueue #-}
@@ -933,9 +957,9 @@ getHoldEventSubscription h = do
934type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
958type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
936−--type role BehaviorM representational
937-- BehaviorM can sample behaviors
960-- BehaviorM can sample behaviors
938−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
961+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
962+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
940instance Monad (BehaviorM x) where
964instance Monad (BehaviorM x) where
941 {-# INLINE (>>=) #-}
965 {-# INLINE (>>=) #-}
@@ -986,7 +1010,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
989−data Root x (k :: * -> *)
1013+data Root x k
990 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1014 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
991 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1015 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
992 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1016 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1056,25 +1080,25 @@ heightBagVerify b@(HeightBag s c) = if
1056heightBagVerify = id
1080heightBagVerify = id
1059−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1083+data FanSubscribedChildren x k v a = FanSubscribedChildren
1060− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1084+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1061− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1085+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1062− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1086+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1065−data FanSubscribed (x :: *) k
1089+data FanSubscribed x k v
1066− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1090+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1067− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1091+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1068− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1092+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1069 , fanSubscribedParent :: !(EventSubscription x)
1093 , fanSubscribedParent :: !(EventSubscription x)
1070#ifdef DEBUG_NODEIDS
1094#ifdef DEBUG_NODEIDS
1071 , fanSubscribedNodeId :: Int
1095 , fanSubscribedNodeId :: Int
1075−data Fan x k
1099+data Fan x k v
1076− = Fan { fanParent :: !(Event x (DMap k Identity))
1100+ = Fan { fanParent :: !(Event x (DMap k v))
1077− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1101+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1080data SwitchSubscribed x a
1104data SwitchSubscribed x a
@@ -1136,19 +1160,24 @@ instance HasSpiderTimeline x => Align (Event x) where
1136#if MIN_VERSION_these(0, 8, 0)
1160#if MIN_VERSION_these(0, 8, 0)
1137instance HasSpiderTimeline x => Semialign (Event x) where
1161instance HasSpiderTimeline x => Semialign (Event x) where
1163+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1139− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1164+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1166+#if defined(MIN_VERSION_semialign)
1167+ zip x y = mapMaybe justThese $ align x y
1141data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1170data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1142 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1171 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1143 | HoldDyn !(Hold x p)
1172 | HoldDyn !(Hold x p)
1145−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1174+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1147−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1176+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1148newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1177newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1150--TODO: Avoid the duplication between this and R.zipDynWith
1179--TODO: Avoid the duplication between this and R.zipDynWith
1151−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1180+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1152zipDynWith f da db =
1181zipDynWith f da db =
1153 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1182 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1154 ec = flip push eab $ \o -> do
1183 ec = flip push eab $ \o -> do
@@ -1171,18 +1200,12 @@ buildDynamic readV0 v' = do
1171 return d
1200 return d
1173unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1202unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1174−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1203+unsafeBuildDynamic readV0 v' =
1175− where x = (readV0, v')
1204+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1177-- ResultM can read behaviors and events
1206-- ResultM can read behaviors and events
1178type ResultM = EventM
1207type ResultM = EventM
1180−{-# NOINLINE unsafeNewIORef #-}
1181−unsafeNewIORef :: a -> b -> IORef b
1182−unsafeNewIORef a b = unsafePerformIO $ do
1186instance HasSpiderTimeline x => Functor (Event x) where
1209instance HasSpiderTimeline x => Functor (Event x) where
1187 fmap f = push $ return . Just . f
1210 fmap f = push $ return . Just . f
@@ -1195,33 +1218,42 @@ push f e = cacheEvent (pushCheap f e)
1196{-# INLINABLE pull #-}
1219{-# INLINABLE pull #-}
1197pull :: BehaviorM x a -> Behavior x a
1220pull :: BehaviorM x a -> Behavior x a
1198−pull a = behaviorPull $ Pull
1221+pull a = unsafePerformIO $ do
1199− { pullCompute = a
1222+ ref <- newIORef Nothing
1200− , pullValue = unsafeNewIORef a Nothing
1201#ifdef DEBUG_NODEIDS
1223#ifdef DEBUG_NODEIDS
1202− , pullNodeId = unsafeNodeId a
1224+ nid <- newNodeId
1226+ pure $ behaviorPull $ Pull
1229+#ifdef DEBUG_NODEIDS
1206{-# INLINABLE switch #-}
1234{-# INLINABLE switch #-}
1207switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1235switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1236+switch a = unsafePerformIO $ do
1237+ ref <- newIORef Nothing
1208−switch a = eventSwitch $ Switch
1238+ pure $ eventSwitch $ Switch
1209− { switchParent = a
1239+ { switchParent = a
1210− , switchSubscribed = unsafeNewIORef a Nothing
1240+ , switchSubscribed = ref
1213coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1243coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1244+coincidence a = unsafePerformIO $ do
1245+ ref <- newIORef Nothing
1214−coincidence a = eventCoincidence $ Coincidence
1246+ pure $ eventCoincidence $ Coincidence
1215− { coincidenceParent = a
1247+ { coincidenceParent = a
1216− , coincidenceSubscribed = unsafeNewIORef a Nothing
1248+ , coincidenceSubscribed = ref
1219-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1251-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1220run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1252run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1221run roots after = do
1253run roots after = do
1222 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1254 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1223 let t = spiderTimeline :: SpiderTimelineEnv x
1255 let t = spiderTimeline :: SpiderTimelineEnv x
1224− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1256+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1225 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1257 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1226 occBefore <- liftIO $ do
1258 occBefore <- liftIO $ do
1227 occBefore <- readIORef occRef
1259 occBefore <- readIORef occRef
@@ -1285,9 +1317,9 @@ type WeakList a = [Weak a]
1285withIncreasedDepth :: CanTrace x m => m a -> m a
1317withIncreasedDepth :: CanTrace x m => m a -> m a
1286withIncreasedDepth a = do
1318withIncreasedDepth a = do
1287 spiderTimeline <- askSpiderTimelineEnv
1319 spiderTimeline <- askSpiderTimelineEnv
1288− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1320+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1289 result <- a
1321 result <- a
1290− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1322+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1291 return result
1323 return result
1293withIncreasedDepth :: m a -> m a
1325withIncreasedDepth :: m a -> m a
@@ -1314,7 +1346,7 @@ traceMWhen _ b getMessage = when b $ do
1314 message <- getMessage
1346 message <- getMessage
1315#ifdef DEBUG
1347#ifdef DEBUG
1316 spiderTimeline <- askSpiderTimelineEnv
1348 spiderTimeline <- askSpiderTimelineEnv
1317− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1349+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1319 let d = 0
1351 let d = 0
@@ -1355,25 +1387,25 @@ propagateSubscriberHold h a = do
1355data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1387data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1357runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1389runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1358−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1390+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1360askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1392askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1361askInvalidator = do
1393askInvalidator = do
1362− (!m, _) <- BehaviorM ask
1394+ (!m, _) <- ask
1363 case m of
1395 case m of
1364 Nothing -> return Nothing
1396 Nothing -> return Nothing
1365 Just (!wi, _) -> return $ Just wi
1397 Just (!wi, _) -> return $ Just wi
1367askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1399askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1368askParentsRef = do
1400askParentsRef = do
1369− (!m, _) <- BehaviorM ask
1401+ (!m, _) <- ask
1370 case m of
1402 case m of
1371 Nothing -> return Nothing
1403 Nothing -> return Nothing
1372 Just (_, !p) -> return $ Just p
1404 Just (_, !p) -> return $ Just p
1374askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1406askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1375askBehaviorHoldInits = do
1407askBehaviorHoldInits = do
1376− (_, !his) <- BehaviorM ask
1408+ (_, !his) <- ask
1377 return his
1409 return his
1379{-# INLINE getDynHold #-}
1411{-# INLINE getDynHold #-}
@@ -1418,6 +1450,9 @@ getRootSubscribed k r sub = do
1418 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1450 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1419 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1451 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1420 writeIORef uninitRef $! uninit
1452 writeIORef uninitRef $! uninit
1453+#ifdef DEBUG_NODEIDS
1421 let !subscribed = RootSubscribed
1456 let !subscribed = RootSubscribed
1422 { rootSubscribedKey = k
1457 { rootSubscribedKey = k
1423 , rootSubscribedCachedSubscribed = cached
1458 , rootSubscribedCachedSubscribed = cached
@@ -1426,7 +1461,7 @@ getRootSubscribed k r sub = do
1426 , rootSubscribedUninit = uninit
1461 , rootSubscribedUninit = uninit
1427 , rootSubscribedWeakSelf = weakSelf
1462 , rootSubscribedWeakSelf = weakSelf
1428#ifdef DEBUG_NODEIDS
1463#ifdef DEBUG_NODEIDS
1429− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1464+ , rootSubscribedNodeId = nid
1432 -- If we die at the same moment that all our children die, they will
1467 -- If we die at the same moment that all our children die, they will
@@ -1475,16 +1510,10 @@ newFanInt = do
1475 , _fanInt_occRef = occRef
1510 , _fanInt_occRef = occRef
1478−{-# NOINLINE unsafeNewFanInt #-}
1479−unsafeNewFanInt :: b -> FanInt x a
1480−unsafeNewFanInt b = unsafePerformIO $ do
1484fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1513fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1485−fanInt p =
1514+fanInt p = unsafePerformIO $ do
1486− let self = unsafeNewFanInt p
1515+ self <- newFanInt
1487− in EventSelectorInt $ \k -> Event $ \sub -> do
1516+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1488 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1517 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1489 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1518 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1490 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1519 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1520,7 +1549,7 @@ fanInt p =
1520 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1549 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1522{-# INLINABLE getFanSubscribed #-}
1551{-# INLINABLE getFanSubscribed #-}
1523−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1552+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))
1524getFanSubscribed k f sub = do
1553getFanSubscribed k f sub = do
1525 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1554 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1526 case mSubscribed of
1555 case mSubscribed of
@@ -1538,13 +1567,16 @@ getFanSubscribed k f sub = do
1538 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1567 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1539 occRef <- liftIO $ newIORef parentOcc
1568 occRef <- liftIO $ newIORef parentOcc
1540 when (isJust parentOcc) $ scheduleClear occRef
1569 when (isJust parentOcc) $ scheduleClear occRef
1570+#ifdef DEBUG_NODEIDS
1571+ nid <- liftIO newNodeId
1541 let subscribed = FanSubscribed
1573 let subscribed = FanSubscribed
1542 { fanSubscribedCachedSubscribed = fanSubscribed f
1574 { fanSubscribedCachedSubscribed = fanSubscribed f
1543 , fanSubscribedOccurrence = occRef
1575 , fanSubscribedOccurrence = occRef
1544 , fanSubscribedParent = subscription
1576 , fanSubscribedParent = subscription
1545 , fanSubscribedSubscribers = subscribersRef
1577 , fanSubscribedSubscribers = subscribersRef
1546#ifdef DEBUG_NODEIDS
1578#ifdef DEBUG_NODEIDS
1547− , fanSubscribedNodeId = unsafeNodeId f
1579+ , fanSubscribedNodeId = nid
1550 let !self = (k, subscribed)
1582 let !self = (k, subscribed)
@@ -1554,7 +1586,7 @@ getFanSubscribed k f sub = do
1554 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1586 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1555 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1587 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1557−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1589+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1558cleanupFanSubscribed (k, subscribed) = do
1590cleanupFanSubscribed (k, subscribed) = do
1559 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1591 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1560 let reducedSubscribers = DMap.delete k subscribers
1592 let reducedSubscribers = DMap.delete k subscribers
@@ -1566,7 +1598,7 @@ cleanupFanSubscribed (k, subscribed) = do
1566 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1598 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1568{-# INLINE subscribeFanSubscribed #-}
1600{-# INLINE subscribeFanSubscribed #-}
1569−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1601+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1570subscribeFanSubscribed k subscribed sub = do
1602subscribeFanSubscribed k subscribed sub = do
1571 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1603 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1572 case DMap.lookup k subscribers of
1604 case DMap.lookup k subscribers of
@@ -1604,6 +1636,9 @@ getSwitchSubscribed s sub = do
1604 when (isJust parentOcc) $ scheduleClear occRef
1636 when (isJust parentOcc) $ scheduleClear occRef
1605 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1637 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1606 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1638 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1639+#ifdef DEBUG_NODEIDS
1640+ nid <- liftIO newNodeId
1607 let !subscribed = SwitchSubscribed
1642 let !subscribed = SwitchSubscribed
1608 { switchSubscribedCachedSubscribed = switchSubscribed s
1643 { switchSubscribedCachedSubscribed = switchSubscribed s
1609 , switchSubscribedOccurrence = occRef
1644 , switchSubscribedOccurrence = occRef
@@ -1616,7 +1651,7 @@ getSwitchSubscribed s sub = do
1616 , switchSubscribedCurrentParent = subscriptionRef
1651 , switchSubscribedCurrentParent = subscriptionRef
1617 , switchSubscribedWeakSelf = weakSelf
1652 , switchSubscribedWeakSelf = weakSelf
1618#ifdef DEBUG_NODEIDS
1653#ifdef DEBUG_NODEIDS
1619− , switchSubscribedNodeId = unsafeNodeId s
1654+ , switchSubscribedNodeId = nid
1622 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1657 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1661,6 +1696,9 @@ getCoincidenceSubscribed c sub = do
1661 scheduleClear innerSubdRef
1696 scheduleClear innerSubdRef
1662 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1697 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1663 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1698 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1699+#ifdef DEBUG_NODEIDS
1700+ nid <- liftIO newNodeId
1664 let subscribed = CoincidenceSubscribed
1702 let subscribed = CoincidenceSubscribed
1665 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1703 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1666 , coincidenceSubscribedOccurrence = occRef
1704 , coincidenceSubscribedOccurrence = occRef
@@ -1671,7 +1709,7 @@ getCoincidenceSubscribed c sub = do
1671 , coincidenceSubscribedInnerParent = innerSubdRef
1709 , coincidenceSubscribedInnerParent = innerSubdRef
1672 , coincidenceSubscribedWeakSelf = weakSelf
1710 , coincidenceSubscribedWeakSelf = weakSelf
1673#ifdef DEBUG_NODEIDS
1711#ifdef DEBUG_NODEIDS
1674− , coincidenceSubscribedNodeId = unsafeNodeId c
1712+ , coincidenceSubscribedNodeId = nid
1677 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1715 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1688,26 +1726,34 @@ cleanupCoincidenceSubscribed subscribed = do
1688subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1726subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1689subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1727subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1691−{-# INLINE merge #-}
1729+{-# INLINE mergeG #-}
1692−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1730+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1731+ => (forall a. q a -> Event x (v a))
1732+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1693−merge d = cacheEvent (mergeCheap d)
1733+mergeG nt d = cacheEvent (mergeCheap nt d)
1695{-# INLINE mergeWithMove #-}
1735{-# INLINE mergeWithMove #-}
1696−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1736+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1737+ => (forall a. q a -> Event x (v a))
1738+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1697−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1739+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1699{-# INLINE [1] mergeCheap #-}
1741{-# INLINE [1] mergeCheap #-}
1700−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1743+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1744+ => (forall a. q a -> Event x (v a))
1745+ -> DynamicS x (PatchDMap k q)
1746+ -> Event x (DMap k v)
1701−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1747+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1703− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1749+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1704 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1750 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1705 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1751 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1706 (mOldSubd, newPs) <- case me of
1752 (mOldSubd, newPs) <- case me of
1707 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1753 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1708 Just e -> do
1754 Just e -> do
1709 let s = subscriber $ return k
1755 let s = subscriber $ return k
1710− subscription@(EventSubscription _ subd) <- subscribe e s
1756+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1711 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1757 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1712 let newParent = MergeSubscribedParent subscription
1758 let newParent = MergeSubscribedParent subscription
1713 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1759 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1717,28 +1763,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1717 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1763 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1718 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1764 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1719 foldM f ([], oldParents) $ DMap.toList p
1765 foldM f ([], oldParents) $ DMap.toList p
1720− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1767+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1721 getInitialSubscribers initialParents subscriber = do
1768 getInitialSubscribers initialParents subscriber = do
1722 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1769 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1723 let s = subscriber $ return k
1770 let s = subscriber $ return k
1724− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1771+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1725 height <- liftIO $ getEventSubscribedHeight parentSubd
1772 height <- liftIO $ getEventSubscribedHeight parentSubd
1726− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1773+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1727 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1774 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1728 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1775 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1729 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1776 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1731 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1779 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1732 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1780 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1734{-# INLINE [1] mergeCheapWithMove #-}
1782{-# INLINE [1] mergeCheapWithMove #-}
1735−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1783+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1784+ => (forall a. q a -> Event x (v a))
1785+ -> DynamicS x (PatchDMapWithMove k q)
1786+ -> Event x (DMap k v)
1736−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1787+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1738− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1789+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1739 updateMe subscriber heightBagRef oldParents p = do
1790 updateMe subscriber heightBagRef oldParents p = do
1740 -- Prepare new parents for insertion
1791 -- Prepare new parents for insertion
1741− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1792+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1742 subscribeParent k e = do
1793 subscribeParent k e = do
1743 keyRef <- liftIO $ newIORef k
1794 keyRef <- liftIO $ newIORef k
1744 let s = subscriber $ liftIO $ readIORef keyRef
1795 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1747,9 +1798,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1747 newParentHeight <- getEventSubscribedHeight subd
1798 newParentHeight <- getEventSubscribedHeight subd
1748 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1799 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1749 return $ MergeSubscribedParentWithMove subscription keyRef
1800 return $ MergeSubscribedParentWithMove subscription keyRef
1750− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1801+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1751 -- Collect old parents for deletion and update the keys of moved parents
1802 -- Collect old parents for deletion and update the keys of moved parents
1752− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1803+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1753 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1804 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1754 Nothing -> do
1805 Nothing -> do
1755 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1806 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1760,46 +1811,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1760 return Nothing
1811 return Nothing
1761 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1812 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1762 return (toDelete, applyAlways p' oldParents)
1813 return (toDelete, applyAlways p' oldParents)
1763− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1814+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1764 getInitialSubscribers initialParents subscriber = do
1815 getInitialSubscribers initialParents subscriber = do
1765 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1816 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1766 keyRef <- liftIO $ newIORef k
1817 keyRef <- liftIO $ newIORef k
1767 let s = subscriber $ liftIO $ readIORef keyRef
1818 let s = subscriber $ liftIO $ readIORef keyRef
1768− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1819+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1769 height <- liftIO $ getEventSubscribedHeight parentSubd
1820 height <- liftIO $ getEventSubscribedHeight parentSubd
1770− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1821+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1771 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1822 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1772 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1823 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1773 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1824 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1775 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1827 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1776 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1828 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1778−type MergeUpdateFunc k x p s
1830+type MergeUpdateFunc k v x p s
1779− = (forall a. EventM x (k a) -> Subscriber x a)
1831+ = (forall a. EventM x (k a) -> Subscriber x (v a))
1780 -> IORef HeightBag
1832 -> IORef HeightBag
1781 -> DMap k s
1833 -> DMap k s
1783 -> EventM x ([EventSubscription x], DMap k s)
1835 -> EventM x ([EventSubscription x], DMap k s)
1785−type MergeInitFunc k x s
1837+type MergeInitFunc k v q x s
1786− = DMap k (Event x)
1838+ = DMap k q
1787− -> (forall a. EventM x (k a) -> Subscriber x a)
1839+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1788− -> EventM x (DMap k Identity, [Height], DMap k s)
1840+ -> EventM x (DMap k v, [Height], DMap k s)
1790type MergeDestroyFunc k s
1842type MergeDestroyFunc k s
1791 = DMap k s
1843 = DMap k s
1792 -> IO ()
1844 -> IO ()
1794−data Merge x k s = Merge
1846+data Merge x k v s = Merge
1795 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1847 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1796 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1848 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1797 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1849 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1798− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1850+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1799− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1851+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1802−invalidateMergeHeight :: Merge x k s -> IO ()
1854+invalidateMergeHeight :: Merge x k v s -> IO ()
1803invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1855invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1805invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1857invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1809,8 +1861,7 @@ invalidateMergeHeight' heightRef sub = do
1809 writeIORef heightRef $! invalidHeight
1861 writeIORef heightRef $! invalidHeight
1810 subscriberInvalidateHeight sub oldHeight
1862 subscriberInvalidateHeight sub oldHeight
1813−revalidateMergeHeight :: Merge x k s -> IO ()
1864+revalidateMergeHeight :: Merge x k v s -> IO ()
1814revalidateMergeHeight m = do
1865revalidateMergeHeight m = do
1815 currentHeight <- readIORef $ _merge_heightRef m
1866 currentHeight <- readIORef $ _merge_heightRef m
1816 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1867 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1826,19 +1877,19 @@ revalidateMergeHeight m = do
1826 subscriberRecalculateHeight (_merge_sub m) height
1877 subscriberRecalculateHeight (_merge_sub m) height
1827 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1878 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1829−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1880+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1830scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1881scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1831 vals <- liftIO $ readIORef $ _merge_accumRef m
1882 vals <- liftIO $ readIORef $ _merge_accumRef m
1832 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
1883 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
1833 --TODO: Assert that m is not empty
1884 --TODO: Assert that m is not empty
1834 subscriberPropagate (_merge_sub m) vals
1885 subscriberPropagate (_merge_sub m) vals
1836−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1887+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1837mergeSubscriber m getKey = Subscriber
1888mergeSubscriber m getKey = Subscriber
1838 { subscriberPropagate = \a -> do
1889 { subscriberPropagate = \a -> do
1839 oldM <- liftIO $ readIORef $ _merge_accumRef m
1890 oldM <- liftIO $ readIORef $ _merge_accumRef m
1840 k <- getKey
1891 k <- getKey
1841− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1892+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1842 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1893 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1843 liftIO $ writeIORef (_merge_accumRef m) $! newM
1894 liftIO $ writeIORef (_merge_accumRef m) $! newM
1844 when (DMap.null oldM) $ do -- Only schedule the firing once
1895 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1853,7 +1904,7 @@ mergeSubscriber m getKey = Subscriber
1853 else liftIO $ do
1904 else liftIO $ do
1854#ifdef DEBUG_CYCLES
1905#ifdef DEBUG_CYCLES
1855 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1906 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1856− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1907+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1857 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1908 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1859 let cycleInfo = ""
1910 let cycleInfo = ""
@@ -1869,7 +1920,7 @@ mergeSubscriber m getKey = Subscriber
1871--TODO: Be able to run as much of this as possible promptly
1922--TODO: Be able to run as much of this as possible promptly
1872−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1923+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1873updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1924updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1874 where updateMe = do
1925 where updateMe = do
1875 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1926 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1877,9 +1928,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1877 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1928 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1878 return subscriptionsToKill
1929 return subscriptionsToKill
1880−{-# INLINE mergeCheap' #-}
1931+{-# INLINE mergeGCheap' #-}
1932+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1881−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)
1933+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1882−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1934+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1883 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1935 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1884 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1936 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1885 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1937 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1927,11 +1979,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1930−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1982+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1931mergeInt = cacheEvent . mergeIntCheap
1983mergeInt = cacheEvent . mergeIntCheap
1933{-# INLINABLE mergeIntCheap #-}
1985{-# INLINABLE mergeIntCheap #-}
1934−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1986+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1935mergeIntCheap d = Event $ \sub -> do
1987mergeIntCheap d = Event $ \sub -> do
1936 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1988 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1937 accum <- liftIO $ FastMutableIntMap.newEmpty
1989 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2028,14 +2080,16 @@ mergeIntCheap d = Event $ \sub -> do
2030newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2082newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2083+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2032−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2085+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2033−fan e =
2086+fanG e = unsafePerformIO $ do
2087+ ref <- newIORef Nothing
2034 let f = Fan
2088 let f = Fan
2035 { fanParent = e
2089 { fanParent = e
2036− , fanSubscribed = unsafeNewIORef e Nothing
2090+ , fanSubscribed = ref
2038− in EventSelector $ \k -> eventFan k f
2092+ pure $ EventSelectorG $ \k -> eventFan k f
2040runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2094runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2041runHoldInits holdInitRef dynInitRef mergeInitRef = do
2095runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2089,18 +2143,18 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2089-- | Run an event action outside of a frame
2143-- | Run an event action outside of a frame
2090runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2144runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2091runFrame a = SpiderHost $ do
2145runFrame a = SpiderHost $ do
2092− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2146+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2093 let go = do
2147 let go = do
2094 result <- a
2148 result <- a
2095 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
2149 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
2096 return result
2150 return result
2097 result <- runEventM go
2151 result <- runEventM go
2098 toClear <- readIORef $ eventEnvClears env
2152 toClear <- readIORef $ eventEnvClears env
2099− forM_ toClear $ \(Some.This (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2153+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2100 toClearInt <- readIORef $ eventEnvIntClears env
2154 toClearInt <- readIORef $ eventEnvIntClears env
2101− forM_ toClearInt $ \(Some.This (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2155+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2102 toClearRoot <- readIORef $ eventEnvRootClears env
2156 toClearRoot <- readIORef $ eventEnvRootClears env
2103− forM_ toClearRoot $ \(Some.This (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2157+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2104 toAssign <- readIORef $ eventEnvAssignments env
2158 toAssign <- readIORef $ eventEnvAssignments env
2105 toReconnectRef <- newIORef []
2159 toReconnectRef <- newIORef []
2106 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2160 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
@@ -2300,7 +2354,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2300 fail _ = error "Dynamic does not support 'fail'"
2354 fail _ = error "Dynamic does not support 'fail'"
2302{-# INLINABLE newJoinDyn #-}
2356{-# INLINABLE newJoinDyn #-}
2303−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2357+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2304newJoinDyn d =
2358newJoinDyn d =
2305 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2359 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2306 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2360 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2450,7 +2504,7 @@ unsafeNewSpiderTimelineEnv = do
2450#ifdef DEBUG
2504#ifdef DEBUG
2451 depthRef <- newIORef 0
2505 depthRef <- newIORef 0
2453− return $ SpiderTimelineEnv
2507+ return $ STE $ SpiderTimelineEnv
2454 { _spiderTimeline_lock = lock
2508 { _spiderTimeline_lock = lock
2455 , _spiderTimeline_eventEnv = env
2509 , _spiderTimeline_eventEnv = env
2456#ifdef DEBUG
2510#ifdef DEBUG
@@ -2460,19 +2514,19 @@ unsafeNewSpiderTimelineEnv = do
2461-- | Create a new SpiderTimelineEnv
2515-- | Create a new SpiderTimelineEnv
2462newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2516newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2463−newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2517+newSpiderTimeline = withSpiderTimeline (pure . Some)
2465−data LocalSpiderTimeline x s
2519+data LocalSpiderTimeline (x :: Type) s
2467instance Reifies s (SpiderTimelineEnv x) =>
2521instance Reifies s (SpiderTimelineEnv x) =>
2468 HasSpiderTimeline (LocalSpiderTimeline x s) where
2522 HasSpiderTimeline (LocalSpiderTimeline x s) where
2469− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2523+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2471localSpiderTimeline
2525localSpiderTimeline
2472− :: Proxy s
2526+ :: proxy s
2473 -> SpiderTimelineEnv x
2527 -> SpiderTimelineEnv x
2474 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2528 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2475−localSpiderTimeline _ = unsafeCoerce
2529+localSpiderTimeline _ = coerce
2477-- | Pass a new timeline to the given function.
2531-- | Pass a new timeline to the given function.
2478withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2532withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2480,18 +2534,18 @@ withSpiderTimeline k = do
2480 env <- unsafeNewSpiderTimelineEnv
2534 env <- unsafeNewSpiderTimelineEnv
2481 reify env $ \s -> k $ localSpiderTimeline s env
2535 reify env $ \s -> k $ localSpiderTimeline s env
2483−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2537+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2485type ComputeM = EventM
2539type ComputeM = EventM
2487−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2541+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2489instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2543instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2490 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2544 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2491 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2545 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2492 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2546 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2493− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2547+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2494− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2548+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2495 type PullM (SpiderTimeline x) = SpiderPullM x
2549 type PullM (SpiderTimeline x) = SpiderPullM x
2496 type PushM (SpiderTimeline x) = SpiderPushM x
2550 type PushM (SpiderTimeline x) = SpiderPushM x
2497 {-# INLINABLE never #-}
2551 {-# INLINABLE never #-}
@@ -2504,10 +2558,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2504 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2558 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2505 {-# INLINABLE pull #-}
2559 {-# INLINABLE pull #-}
2506 pull = SpiderBehavior . pull . coerce
2560 pull = SpiderBehavior . pull . coerce
2507− {-# INLINABLE merge #-}
2561+ {-# INLINABLE fanG #-}
2508− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2509− {-# INLINABLE fan #-}
2510− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2562+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2563+ {-# INLINABLE mergeG #-}
2565+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2566+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2568+ -> R.Event (SpiderTimeline x) (DMap k v)
2569+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2511 {-# INLINABLE switch #-}
2570 {-# INLINABLE switch #-}
2512 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2571 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2513 {-# INLINABLE coincidence #-}
2572 {-# INLINABLE coincidence #-}
@@ -2515,15 +2574,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2515 {-# INLINABLE current #-}
2574 {-# INLINABLE current #-}
2516 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2575 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2517 {-# INLINABLE updated #-}
2576 {-# INLINABLE updated #-}
2518− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2577+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2519 {-# INLINABLE unsafeBuildDynamic #-}
2578 {-# INLINABLE unsafeBuildDynamic #-}
2520 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2579 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2521 {-# INLINABLE unsafeBuildIncremental #-}
2580 {-# INLINABLE unsafeBuildIncremental #-}
2522 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2581 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2523− {-# INLINABLE mergeIncremental #-}
2582+ {-# INLINABLE mergeIncrementalG #-}
2524− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2583+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2525− {-# INLINABLE mergeIncrementalWithMove #-}
2584+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2526− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2585+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2527 {-# INLINABLE currentIncremental #-}
2586 {-# INLINABLE currentIncremental #-}
2528 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2587 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2529 {-# INLINABLE updatedIncremental #-}
2588 {-# INLINABLE updatedIncremental #-}
@@ -2534,9 +2593,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2534 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2593 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2535 eventCoercion Coercion = Coercion
2594 eventCoercion Coercion = Coercion
2536 behaviorCoercion Coercion = Coercion
2595 behaviorCoercion Coercion = Coercion
2537− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2596+ dynamicCoercion Coercion = Coercion
2597+ incrementalCoercion Coercion Coercion = Coercion
2538 {-# INLINABLE mergeIntIncremental #-}
2598 {-# INLINABLE mergeIntIncremental #-}
2539− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2599+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
2540 {-# INLINABLE fanInt #-}
2600 {-# INLINABLE fanInt #-}
2541 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2601 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
@@ -2561,7 +2621,7 @@ instance MonadAtomicRef (EventM x) where
2561 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2621 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2563-- | The monad for actions that manipulate a Spider timeline identified by @x@
2623-- | The monad for actions that manipulate a Spider timeline identified by @x@
2564−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2624+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2566instance Monad (SpiderHost x) where
2626instance Monad (SpiderHost x) where
2567 {-# INLINABLE (>>=) #-}
2627 {-# INLINABLE (>>=) #-}
@@ -2583,7 +2643,7 @@ runSpiderHost (SpiderHost a) = a
2583runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2643runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2584runSpiderHostForTimeline (SpiderHost a) _ = a
2644runSpiderHostForTimeline (SpiderHost a) _ = a
2586−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2646+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2587 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2647 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2589instance Monad (SpiderHostFrame x) where
2649instance Monad (SpiderHostFrame x) where