@@ -17,9 +17,15 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE DeriveFunctor #-}
22+{-# LANGUAGE StandaloneDeriving #-}
23+{-# LANGUAGE InstanceSigs #-}
24+
2025#ifdef USE_REFLEX_OPTIMIZER
2126{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2227#endif
28+{-# OPTIONS_GHC -Wunused-binds #-}
2329-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2430-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2531module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -33,7 +39,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
3339import Control.Monad.Exception
3440import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
3541import Control.Monad.Primitive
36−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
43+import Control.Monad.Reader.Class
44+import Control.Monad.IO.Class
45+import Control.Monad.ReaderIO
3746import Control.Monad.Ref
3847import Data.Align
3948import Data.Coerce
@@ -49,6 +58,7 @@ import Data.GADT.Compare
4958import Data.IntMap.Strict (IntMap)
5059import qualified Data.IntMap.Strict as IntMap
5160import Data.IORef
61+import Data.Kind (Type)
5262import Data.Maybe hiding (mapMaybe)
5363import Data.Monoid ((<>))
5464import Data.Proxy
@@ -76,6 +86,7 @@ import qualified Data.FastWeakBag as FastWeakBag
7686import Data.Reflection
7787import Data.Some (Some(Some))
7888import Data.Type.Coercion
89+import Data.Profunctor.Unsafe ((#.), (.#))
7990import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
8091import qualified Data.WeakBag as WeakBag
8192import qualified Reflex.Class
@@ -144,12 +155,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
144155
145156newNodeId :: IO Int
146157newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
147−
148−{-# NOINLINE unsafeNodeId #-}
149−unsafeNodeId :: a -> Int
150−unsafeNodeId a = unsafePerformIO $ do
151− touch a
152− newNodeId
153158#endif
154159
155160--------------------------------------------------------------------------------
@@ -253,9 +258,10 @@ cacheEvent e =
253258#else
254259 Event $
255260#endif
256− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
257− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
258− in \sub -> {-# SCC "cacheEvent" #-} do
261+ unsafePerformIO $ do
262+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
263+ <- newIORef emptyFastWeak
264+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
259265#ifdef DEBUG_TRACE_EVENTS
260266 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
261267#endif
@@ -321,7 +327,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
321327eventNever :: Event x a
322328eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
323329
324−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
330+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
325331eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
326332
327333eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -373,14 +379,14 @@ newSubscriberHold h = return $ Subscriber
373379 , subscriberRecalculateHeight = \_ -> return ()
374380 }
375381
376−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
382+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
377383newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
378384 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
379385 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
380386 tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
381387 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
382388 scheduleClear $ fanSubscribedOccurrence subscribed
383− let f _ (Pair (Identity v) subsubs) = do
389+ let f _ (Pair v subsubs) = do
384390 propagate v $ _fanSubscribedChildren_list subsubs
385391 return $ Constant ()
386392 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -475,6 +481,11 @@ propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
475481toAny :: a -> Any
476482toAny = unsafeCoerce
477483
484+-- Why do we use Any here, instead of just giving eventSubscribedRetained an
485+-- existential type? Sadly, GHC does not currently know how to unbox types
486+-- with existentially quantified fields. So instead we just coerce values
487+-- to type Any on the way in. Since we never coerce them back, this is
488+-- perfectly safe.
478489data EventSubscribed x = EventSubscribed
479490 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
480491 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -507,7 +518,7 @@ eventSubscribedNever = EventSubscribed
507518#endif
508519 }
509520
510−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
521+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
511522eventSubscribedFan !subscribed = EventSubscribed
512523 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
513524 , eventSubscribedRetained = toAny subscribed
@@ -598,7 +609,7 @@ behaviorPull !p = Behavior $ do
598609 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
599610 parentsRef <- liftIO $ newIORef []
600611 holdInits <- askBehaviorHoldInits
601− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
612+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
602613 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
603614 parents <- liftIO $ readIORef parentsRef
604615 let subscribed = PullSubscribed
@@ -633,42 +644,46 @@ readBehaviorUntracked b = do
633644-- Dynamic
634645--------------------------------------------------------------------------------
635646
636−data Dynamic x p = Dynamic
637− { dynamicCurrent :: !(Behavior x (PatchTarget p))
647+type DynamicS x p = Dynamic x (PatchTarget p) p
648+
649+data Dynamic x target p = Dynamic
650+ { dynamicCurrent :: !(Behavior x target)
638651 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
639652 }
640653
641−dynamicHold :: Hold x p -> Dynamic x p
654+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
655+
656+
657+
658+
659+dynamicHold :: Hold x p -> DynamicS x p
642660dynamicHold !h = Dynamic
643661 { dynamicCurrent = behaviorHold h
644662 , dynamicUpdated = eventHold h
645663 }
646664
647−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
665+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
648666dynamicHoldIdentity = dynamicHold
649667
650−dynamicConst :: PatchTarget p -> Dynamic x p
668+dynamicConst :: PatchTarget p -> DynamicS x p
651669dynamicConst !a = Dynamic
652670 { dynamicCurrent = behaviorConst a
653671 , dynamicUpdated = eventNever
654672 }
655673
656−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
674+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
657675dynamicDyn !d = Dynamic
658676 { dynamicCurrent = behaviorDyn d
659677 , dynamicUpdated = eventDyn d
660678 }
661679
662−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
680+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
663681dynamicDynIdentity = dynamicDyn
664682
665683--------------------------------------------------------------------------------
666684-- Combinators
667685--------------------------------------------------------------------------------
668686
669−--TODO: Figure out why certain things are not 'representational', then make them
670−--representational so we can use coerce
671−
672687--type role Hold representational
673688data Hold x p
674689 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -689,20 +704,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
689704
690705-- | Stores all global data relevant to a particular Spider timeline; only one
691706-- value should exist for each type @x@
692−data SpiderTimelineEnv x = SpiderTimelineEnv
707+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
708+-- We implement SpiderTimelineEnv with a newtype wrapper so
709+-- we can get the coercions we want safely.
710+type role SpiderTimelineEnv nominal
711+
712+data SpiderTimelineEnv' x = SpiderTimelineEnv
693713 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
694714 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
695715#ifdef DEBUG
696716 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
697717#endif
698718 }
699−type role SpiderTimelineEnv nominal
719+type role SpiderTimelineEnv' phantom
700720
701721instance Eq (SpiderTimelineEnv x) where
702722 _ == _ = True -- Since only one exists of each type
703723
704724instance GEq SpiderTimelineEnv where
705− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
725+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
706726 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
707727 else Nothing
708728
@@ -725,7 +745,7 @@ runEventM :: EventM x a -> IO a
725745runEventM = unEventM
726746
727747asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
728−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
748+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
729749
730750class MonadIO m => Defer a m where
731751 getDeferralQueue :: m (IORef [a])
@@ -863,9 +883,9 @@ getHoldEventSubscription h = do
863883
864884type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
865885
866−--type role BehaviorM representational
867886-- BehaviorM can sample behaviors
868−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
887+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
888+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
869889
870890instance Monad (BehaviorM x) where
871891 {-# INLINE (>>=) #-}
@@ -916,7 +936,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
916936#endif
917937 }
918938
919−data Root x (k :: * -> *)
939+data Root x k
920940 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
921941 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
922942 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -986,25 +1006,25 @@ heightBagVerify b@(HeightBag s c) = if
9861006heightBagVerify = id
9871007#endif
9881008
989−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
990− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
991− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
992− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1009+data FanSubscribedChildren x k v a = FanSubscribedChildren
1010+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1011+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1012+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
9931013 }
9941014
995−data FanSubscribed (x :: *) k
996− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
997− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
998− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1015+data FanSubscribed x k v
1016+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1017+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1018+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
9991019 , fanSubscribedParent :: !(EventSubscription x)
10001020#ifdef DEBUG_NODEIDS
10011021 , fanSubscribedNodeId :: Int
10021022#endif
10031023 }
10041024
1005−data Fan x k
1006− = Fan { fanParent :: !(Event x (DMap k Identity))
1007− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1025+data Fan x k v
1026+ = Fan { fanParent :: !(Event x (DMap k v))
1027+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
10081028 }
10091029
10101030data SwitchSubscribed x a
@@ -1066,19 +1086,20 @@ instance HasSpiderTimeline x => Align (Event x) where
10661086#if MIN_VERSION_these(0, 8, 0)
10671087instance HasSpiderTimeline x => Semialign (Event x) where
10681088#endif
1069− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1089+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1090+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
10701091
10711092data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
10721093 | BuildDyn !(EventM x (PatchTarget p), Event x p)
10731094 | HoldDyn !(Hold x p)
10741095
1075−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1096+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
10761097
1077−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1098+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
10781099newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
10791100
10801101--TODO: Avoid the duplication between this and R.zipDynWith
1081−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1102+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
10821103zipDynWith f da db =
10831104 let eab = align (dynamicUpdated da) (dynamicUpdated db)
10841105 ec = flip push eab $ \o -> do
@@ -1101,18 +1122,12 @@ buildDynamic readV0 v' = do
11011122 return d
11021123
11031124unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1104−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1105− where x = (readV0, v')
1125+unsafeBuildDynamic readV0 v' =
1126+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
11061127
11071128-- ResultM can read behaviors and events
11081129type ResultM = EventM
11091130
1110−{-# NOINLINE unsafeNewIORef #-}
1111−unsafeNewIORef :: a -> b -> IORef b
1112−unsafeNewIORef a b = unsafePerformIO $ do
1113− touch a
1114− newIORef b
1115−
11161131instance HasSpiderTimeline x => Functor (Event x) where
11171132 fmap f = push $ return . Just . f
11181133
@@ -1125,33 +1140,42 @@ push f e = cacheEvent (pushCheap f e)
11251140
11261141{-# INLINABLE pull #-}
11271142pull :: BehaviorM x a -> Behavior x a
1128−pull a = behaviorPull $ Pull
1129− { pullCompute = a
1130− , pullValue = unsafeNewIORef a Nothing
1143+pull a = unsafePerformIO $ do
1144+ ref <- newIORef Nothing
11311145#ifdef DEBUG_NODEIDS
1132− , pullNodeId = unsafeNodeId a
1146+ nid <- newNodeId
11331147#endif
1134− }
1148+ pure $ behaviorPull $ Pull
1149+ { pullCompute = a
1150+ , pullValue = ref
1151+#ifdef DEBUG_NODEIDS
1152+ , pullNodeId = nid
1153+#endif
1154+ }
11351155
11361156{-# INLINABLE switch #-}
11371157switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1138−switch a = eventSwitch $ Switch
1139− { switchParent = a
1140− , switchSubscribed = unsafeNewIORef a Nothing
1141− }
1158+switch a = unsafePerformIO $ do
1159+ ref <- newIORef Nothing
1160+ pure $ eventSwitch $ Switch
1161+ { switchParent = a
1162+ , switchSubscribed = ref
1163+ }
11421164
11431165coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1144−coincidence a = eventCoincidence $ Coincidence
1145− { coincidenceParent = a
1146− , coincidenceSubscribed = unsafeNewIORef a Nothing
1147− }
1166+coincidence a = unsafePerformIO $ do
1167+ ref <- newIORef Nothing
1168+ pure $ eventCoincidence $ Coincidence
1169+ { coincidenceParent = a
1170+ , coincidenceSubscribed = ref
1171+ }
11481172
11491173-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
11501174run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
11511175run roots after = do
11521176 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
11531177 let t = spiderTimeline :: SpiderTimelineEnv x
1154− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1178+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
11551179 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
11561180 occBefore <- liftIO $ do
11571181 occBefore <- readIORef occRef
@@ -1237,9 +1261,9 @@ debugSubscriber description subscribed = return $ Subscriber
12371261{-# INLINE withIncreasedDepth #-}
12381262withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
12391263withIncreasedDepth _ a = do
1240− liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) succ
1264+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ
12411265 result <- a
1242− liftIO $ modifyIORef' (_spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)) pred
1266+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
12431267 return result
12441268
12451269{-# INLINE tracePropagate #-}
@@ -1258,7 +1282,7 @@ trace p message = traceM p $ return message
12581282traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
12591283traceM _ getMessage = do
12601284 message <- getMessage
1261− d <- liftIO $ readIORef $ _spiderTimeline_depth (spiderTimeline :: SpiderTimelineEnv x)
1285+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
12621286 liftIO $ putStrLn $ replicate d ' ' <> message
12631287
12641288#else
@@ -1329,25 +1353,25 @@ propagateSubscriberHold h a = do
13291353data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
13301354
13311355runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1332−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1356+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
13331357
13341358askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
13351359askInvalidator = do
1336− (!m, _) <- BehaviorM ask
1360+ (!m, _) <- ask
13371361 case m of
13381362 Nothing -> return Nothing
13391363 Just (!wi, _) -> return $ Just wi
13401364
13411365askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
13421366askParentsRef = do
1343− (!m, _) <- BehaviorM ask
1367+ (!m, _) <- ask
13441368 case m of
13451369 Nothing -> return Nothing
13461370 Just (_, !p) -> return $ Just p
13471371
13481372askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
13491373askBehaviorHoldInits = do
1350− (_, !his) <- BehaviorM ask
1374+ (_, !his) <- ask
13511375 return his
13521376
13531377{-# INLINE getDynHold #-}
@@ -1394,6 +1418,9 @@ getRootSubscribed k r sub = do
13941418
13951419 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
13961420 writeIORef uninitRef $! uninit
1421+#ifdef DEBUG_NODEIDS
1422+ nid <- newNodeId
1423+#endif
13971424 let !subscribed = RootSubscribed
13981425 { rootSubscribedKey = k
13991426 , rootSubscribedCachedSubscribed = cached
@@ -1402,7 +1429,7 @@ getRootSubscribed k r sub = do
14021429 , rootSubscribedUninit = uninit
14031430 , rootSubscribedWeakSelf = weakSelf
14041431#ifdef DEBUG_NODEIDS
1405− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1432+ , rootSubscribedNodeId = nid
14061433#endif
14071434 }
14081435 -- If we die at the same moment that all our children die, they will
@@ -1451,16 +1478,10 @@ newFanInt = do
14511478 , _fanInt_occRef = occRef
14521479 }
14531480
1454−{-# NOINLINE unsafeNewFanInt #-}
1455−unsafeNewFanInt :: b -> FanInt x a
1456−unsafeNewFanInt b = unsafePerformIO $ do
1457− touch b
1458− newFanInt
1459−
14601481fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1461−fanInt p =
1462− let self = unsafeNewFanInt p
1463− in EventSelectorInt $ \k -> Event $ \sub -> do
1482+fanInt p = unsafePerformIO $ do
1483+ self <- newFanInt
1484+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
14641485 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
14651486 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
14661487 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1496,7 +1517,7 @@ fanInt p =
14961517 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
14971518
14981519{-# INLINABLE getFanSubscribed #-}
1499−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1520+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))
15001521getFanSubscribed k f sub = do
15011522 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
15021523 case mSubscribed of
@@ -1514,13 +1535,16 @@ getFanSubscribed k f sub = do
15141535 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
15151536 occRef <- liftIO $ newIORef parentOcc
15161537 when (isJust parentOcc) $ scheduleClear occRef
1538+#ifdef DEBUG_NODEIDS
1539+ nid <- liftIO newNodeId
1540+#endif
15171541 let subscribed = FanSubscribed
15181542 { fanSubscribedCachedSubscribed = fanSubscribed f
15191543 , fanSubscribedOccurrence = occRef
15201544 , fanSubscribedParent = subscription
15211545 , fanSubscribedSubscribers = subscribersRef
15221546#ifdef DEBUG_NODEIDS
1523− , fanSubscribedNodeId = unsafeNodeId f
1547+ , fanSubscribedNodeId = nid
15241548#endif
15251549 }
15261550 let !self = (k, subscribed)
@@ -1530,7 +1554,7 @@ getFanSubscribed k f sub = do
15301554 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
15311555 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
15321556
1533−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1557+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
15341558cleanupFanSubscribed (k, subscribed) = do
15351559 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15361560 let reducedSubscribers = DMap.delete k subscribers
@@ -1542,7 +1566,7 @@ cleanupFanSubscribed (k, subscribed) = do
15421566 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
15431567
15441568{-# INLINE subscribeFanSubscribed #-}
1545−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1569+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
15461570subscribeFanSubscribed k subscribed sub = do
15471571 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15481572 case DMap.lookup k subscribers of
@@ -1580,6 +1604,9 @@ getSwitchSubscribed s sub = do
15801604 when (isJust parentOcc) $ scheduleClear occRef
15811605 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
15821606 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1607+#ifdef DEBUG_NODEIDS
1608+ nid <- liftIO newNodeId
1609+#endif
15831610 let !subscribed = SwitchSubscribed
15841611 { switchSubscribedCachedSubscribed = switchSubscribed s
15851612 , switchSubscribedOccurrence = occRef
@@ -1592,7 +1619,7 @@ getSwitchSubscribed s sub = do
15921619 , switchSubscribedCurrentParent = subscriptionRef
15931620 , switchSubscribedWeakSelf = weakSelf
15941621#ifdef DEBUG_NODEIDS
1595− , switchSubscribedNodeId = unsafeNodeId s
1622+ , switchSubscribedNodeId = nid
15961623#endif
15971624 }
15981625 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1637,6 +1664,9 @@ getCoincidenceSubscribed c sub = do
16371664 scheduleClear innerSubdRef
16381665 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
16391666 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1667+#ifdef DEBUG_NODEIDS
1668+ nid <- liftIO newNodeId
1669+#endif
16401670 let subscribed = CoincidenceSubscribed
16411671 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
16421672 , coincidenceSubscribedOccurrence = occRef
@@ -1647,7 +1677,7 @@ getCoincidenceSubscribed c sub = do
16471677 , coincidenceSubscribedInnerParent = innerSubdRef
16481678 , coincidenceSubscribedWeakSelf = weakSelf
16491679#ifdef DEBUG_NODEIDS
1650− , coincidenceSubscribedNodeId = unsafeNodeId c
1680+ , coincidenceSubscribedNodeId = nid
16511681#endif
16521682 }
16531683 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1664,26 +1694,34 @@ cleanupCoincidenceSubscribed subscribed = do
16641694subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
16651695subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
16661696
1667−{-# INLINE merge #-}
1668−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1669−merge d = cacheEvent (mergeCheap d)
1697+{-# INLINE mergeG #-}
1698+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1699+ => (forall a. q a -> Event x (v a))
1700+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1701+mergeG nt d = cacheEvent (mergeCheap nt d)
16701702
16711703{-# INLINE mergeWithMove #-}
1672−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1673−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1704+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1705+ => (forall a. q a -> Event x (v a))
1706+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1707+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
16741708
16751709{-# INLINE [1] mergeCheap #-}
1676−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1677−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1710+mergeCheap
1711+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1712+ => (forall a. q a -> Event x (v a))
1713+ -> DynamicS x (PatchDMap k q)
1714+ -> Event x (DMap k v)
1715+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
16781716 where
1679− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1717+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
16801718 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
16811719 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
16821720 (mOldSubd, newPs) <- case me of
16831721 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
16841722 Just e -> do
16851723 let s = subscriber $ return k
1686− subscription@(EventSubscription _ subd) <- subscribe e s
1724+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
16871725 newParentHeight <- liftIO $ getEventSubscribedHeight subd
16881726 let newParent = MergeSubscribedParent subscription
16891727 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1693,28 +1731,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
16931731 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
16941732 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
16951733 foldM f ([], oldParents) $ DMap.toList p
1696− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1734+
1735+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
16971736 getInitialSubscribers initialParents subscriber = do
16981737 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
16991738 let s = subscriber $ return k
1700− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1739+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17011740 height <- liftIO $ getEventSubscribedHeight parentSubd
1702− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1741+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)
17031742 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17041743 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17051744 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17061745 )
1746+
17071747 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
17081748 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
17091749
17101750{-# INLINE [1] mergeCheapWithMove #-}
1711−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1712−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1751+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1752+ => (forall a. q a -> Event x (v a))
1753+ -> DynamicS x (PatchDMapWithMove k q)
1754+ -> Event x (DMap k v)
1755+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17131756 where
1714− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1757+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
17151758 updateMe subscriber heightBagRef oldParents p = do
17161759 -- Prepare new parents for insertion
1717− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1760+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
17181761 subscribeParent k e = do
17191762 keyRef <- liftIO $ newIORef k
17201763 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1723,9 +1766,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17231766 newParentHeight <- getEventSubscribedHeight subd
17241767 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17251768 return $ MergeSubscribedParentWithMove subscription keyRef
1726− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1769+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
17271770 -- Collect old parents for deletion and update the keys of moved parents
1728− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1771+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17291772 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17301773 Nothing -> do
17311774 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1736,46 +1779,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17361779 return Nothing
17371780 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
17381781 return (toDelete, applyAlways p' oldParents)
1739− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1782+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
17401783 getInitialSubscribers initialParents subscriber = do
17411784 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17421785 keyRef <- liftIO $ newIORef k
17431786 let s = subscriber $ liftIO $ readIORef keyRef
1744− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1787+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17451788 height <- liftIO $ getEventSubscribedHeight parentSubd
1746− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1789+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
17471790 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17481791 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17491792 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17501793 )
1794+
17511795 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
17521796 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
17531797
1754−type MergeUpdateFunc k x p s
1755− = (forall a. EventM x (k a) -> Subscriber x a)
1798+type MergeUpdateFunc k v x p s
1799+ = (forall a. EventM x (k a) -> Subscriber x (v a))
17561800 -> IORef HeightBag
17571801 -> DMap k s
17581802 -> p
17591803 -> EventM x ([EventSubscription x], DMap k s)
17601804
1761−type MergeInitFunc k x s
1762− = DMap k (Event x)
1763− -> (forall a. EventM x (k a) -> Subscriber x a)
1764− -> EventM x (DMap k Identity, [Height], DMap k s)
1805+type MergeInitFunc k v q x s
1806+ = DMap k q
1807+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1808+ -> EventM x (DMap k v, [Height], DMap k s)
17651809
17661810type MergeDestroyFunc k s
17671811 = DMap k s
17681812 -> IO ()
17691813
1770−data Merge x k s = Merge
1814+data Merge x k v s = Merge
17711815 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
17721816 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
17731817 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1774− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1775− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1818+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1819+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
17761820 }
17771821
1778−invalidateMergeHeight :: Merge x k s -> IO ()
1822+invalidateMergeHeight :: Merge x k v s -> IO ()
17791823invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
17801824
17811825invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1785,8 +1829,7 @@ invalidateMergeHeight' heightRef sub = do
17851829 writeIORef heightRef $! invalidHeight
17861830 subscriberInvalidateHeight sub oldHeight
17871831
1788−
1789−revalidateMergeHeight :: Merge x k s -> IO ()
1832+revalidateMergeHeight :: Merge x k v s -> IO ()
17901833revalidateMergeHeight m = do
17911834 currentHeight <- readIORef $ _merge_heightRef m
17921835 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1802,19 +1845,19 @@ revalidateMergeHeight m = do
18021845 subscriberRecalculateHeight (_merge_sub m) height
18031846 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
18041847
1805−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1848+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
18061849scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18071850 vals <- liftIO $ readIORef $ _merge_accumRef m
18081851 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
18091852 --TODO: Assert that m is not empty
18101853 subscriberPropagate (_merge_sub m) vals
18111854
1812−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1855+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
18131856mergeSubscriber m getKey = Subscriber
18141857 { subscriberPropagate = \a -> do
18151858 oldM <- liftIO $ readIORef $ _merge_accumRef m
18161859 k <- getKey
1817− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1860+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
18181861 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
18191862 liftIO $ writeIORef (_merge_accumRef m) $! newM
18201863 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1845,7 +1888,7 @@ mergeSubscriber m getKey = Subscriber
18451888 }
18461889
18471890--TODO: Be able to run as much of this as possible promptly
1848−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1891+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
18491892updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
18501893 where updateMe = do
18511894 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1853,9 +1896,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
18531896 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
18541897 return subscriptionsToKill
18551898
1856−{-# INLINE mergeCheap' #-}
1857−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)
1858−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1899+{-# INLINE mergeGCheap' #-}
1900+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1901+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1902+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
18591903 initialParents <- readBehaviorUntracked $ dynamicCurrent d
18601904 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
18611905 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1903,11 +1947,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
19031947 , occ
19041948 )
19051949
1906−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1950+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
19071951mergeInt = cacheEvent . mergeIntCheap
19081952
19091953{-# INLINABLE mergeIntCheap #-}
1910−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1954+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
19111955mergeIntCheap d = Event $ \sub -> do
19121956 initialParents <- readBehaviorUntracked $ dynamicCurrent d
19131957 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2004,14 +2048,16 @@ mergeIntCheap d = Event $ \sub -> do
20042048 )
20052049
20062050newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2051+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
20072052
2008−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2009−fan e =
2053+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2054+fanG e = unsafePerformIO $ do
2055+ ref <- newIORef Nothing
20102056 let f = Fan
20112057 { fanParent = e
2012− , fanSubscribed = unsafeNewIORef e Nothing
2058+ , fanSubscribed = ref
20132059 }
2014− in EventSelector $ \k -> eventFan k f
2060+ pure $ EventSelectorG $ \k -> eventFan k f
20152061
20162062runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
20172063runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2065,7 +2111,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
20652111-- | Run an event action outside of a frame
20662112runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
20672113runFrame a = SpiderHost $ do
2068− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2114+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
20692115 let go = do
20702116 result <- a
20712117 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
@@ -2276,7 +2322,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
22762322 fail _ = error "Dynamic does not support 'fail'"
22772323
22782324{-# INLINABLE newJoinDyn #-}
2279−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2325+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
22802326newJoinDyn d =
22812327 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
22822328 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2426,7 +2472,7 @@ unsafeNewSpiderTimelineEnv = do
24262472#ifdef DEBUG
24272473 depthRef <- newIORef 0
24282474#endif
2429− return $ SpiderTimelineEnv
2475+ return $ STE $ SpiderTimelineEnv
24302476 { _spiderTimeline_lock = lock
24312477 , _spiderTimeline_eventEnv = env
24322478#ifdef DEBUG
@@ -2438,17 +2484,17 @@ unsafeNewSpiderTimelineEnv = do
24382484newSpiderTimeline :: IO (Some SpiderTimelineEnv)
24392485newSpiderTimeline = withSpiderTimeline (pure . Some)
24402486
2441−data LocalSpiderTimeline x s
2487+data LocalSpiderTimeline (x :: Type) s
24422488
24432489instance Reifies s (SpiderTimelineEnv x) =>
24442490 HasSpiderTimeline (LocalSpiderTimeline x s) where
2445− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2491+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
24462492
24472493localSpiderTimeline
2448− :: Proxy s
2494+ :: proxy s
24492495 -> SpiderTimelineEnv x
24502496 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2451−localSpiderTimeline _ = unsafeCoerce
2497+localSpiderTimeline _ = coerce
24522498
24532499-- | Pass a new timeline to the given function.
24542500withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2456,18 +2502,18 @@ withSpiderTimeline k = do
24562502 env <- unsafeNewSpiderTimelineEnv
24572503 reify env $ \s -> k $ localSpiderTimeline s env
24582504
2459−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2505+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24602506
24612507type ComputeM = EventM
24622508
2463−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2509+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24642510
24652511instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
24662512 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
24672513 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
24682514 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2469− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2470− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2515+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2516+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
24712517 type PullM (SpiderTimeline x) = SpiderPullM x
24722518 type PushM (SpiderTimeline x) = SpiderPushM x
24732519 {-# INLINABLE never #-}
@@ -2480,10 +2526,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
24802526 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
24812527 {-# INLINABLE pull #-}
24822528 pull = SpiderBehavior . pull . coerce
2483− {-# INLINABLE merge #-}
2484− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2485− {-# INLINABLE fan #-}
2486− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2529+ {-# INLINABLE fanG #-}
2530+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2531+ {-# INLINABLE mergeG #-}
2532+ mergeG
2533+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2534+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2535+ -> DMap k q
2536+ -> R.Event (SpiderTimeline x) (DMap k v)
2537+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
24872538 {-# INLINABLE switch #-}
24882539 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
24892540 {-# INLINABLE coincidence #-}
@@ -2491,15 +2542,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
24912542 {-# INLINABLE current #-}
24922543 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
24932544 {-# INLINABLE updated #-}
2494− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2545+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
24952546 {-# INLINABLE unsafeBuildDynamic #-}
24962547 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
24972548 {-# INLINABLE unsafeBuildIncremental #-}
24982549 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2499− {-# INLINABLE mergeIncremental #-}
2500− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2501− {-# INLINABLE mergeIncrementalWithMove #-}
2502− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2550+ {-# INLINABLE mergeIncrementalG #-}
2551+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2552+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2553+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
25032554 {-# INLINABLE currentIncremental #-}
25042555 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
25052556 {-# INLINABLE updatedIncremental #-}
@@ -2510,9 +2561,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25102561 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
25112562 eventCoercion Coercion = Coercion
25122563 behaviorCoercion Coercion = Coercion
2513− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2564+ dynamicCoercion Coercion = Coercion
2565+ incrementalCoercion Coercion Coercion = Coercion
25142566 {-# INLINABLE mergeIntIncremental #-}
2515− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2567+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
25162568 {-# INLINABLE fanInt #-}
25172569 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
25182570
@@ -2537,7 +2589,7 @@ instance MonadAtomicRef (EventM x) where
25372589 atomicModifyRef r f = liftIO $ atomicModifyRef r f
25382590
25392591-- | The monad for actions that manipulate a Spider timeline identified by @x@
2540−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2592+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25412593
25422594instance Monad (SpiderHost x) where
25432595 {-# INLINABLE (>>=) #-}
@@ -2559,7 +2611,7 @@ runSpiderHost (SpiderHost a) = a
25592611runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
25602612runSpiderHostForTimeline (SpiderHost a) _ = a
25612613
2562−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2614+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
25632615 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25642616
25652617instance Monad (SpiderHostFrame x) where