@@ -45,6 +45,7 @@ import Data.IORef
4545import Data.List hiding (foldl')
4646import Data.Maybe
4747import Data.Monoid ((<>))
48+import Data.Proxy
4849import Data.Some (Some)
4950import qualified Data.Some as Some
5051import Data.These
@@ -185,7 +186,7 @@ newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (Even
185186-- caching; if the computation function is very cheap, this is (much) more
186187-- efficient than 'push'
187188{-# INLINABLE pushCheap #-}
188−pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
189+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
189190pushCheap f e = Event $ \sub -> do
190191 (subscription, occ) <- subscribeAndRead e $ sub
191192 { subscriberPropagate = \a -> do
@@ -210,7 +211,7 @@ data CacheSubscribed x a
210211--there's only one subscriber, and then build our own WeakBag only when a second
211212--subscriber joins
212213{-# INLINABLE cacheEvent #-}
213−cacheEvent :: Event x a -> Event x a
214+cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
214215cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
215216 let !mSubscribedRef = unsafeNewIORef e Nothing
216217 mSubscribed <- liftIO $ readIORef mSubscribedRef
@@ -271,19 +272,19 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
271272eventNever :: Event x a
272273eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
273274
274−eventFan :: GCompare k => k a -> Fan x k -> Event x a
275+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
275276eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
276277
277−eventSwitch :: Switch x a -> Event x a
278+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
278279eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
279280
280−eventCoincidence :: Coincidence x a -> Event x a
281+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
281282eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
282283
283−eventHold :: Hold x p -> Event x p
284+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
284285eventHold !h = Event $ subscribeHoldEvent h
285286
286−eventDyn :: R.Patch p => Dyn x p -> Event x p
287+eventDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Event x p
287288eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
288289
289290{-# INLINE subscribeCoincidenceInner #-}
@@ -316,18 +317,18 @@ data Subscriber x a = Subscriber
316317-- The result is also evaluated to WHNF, since forcing a thunk invalidates
317318-- the weak pointer to it in some cases.
318319
319−newSubscriberHold :: R.Patch p => Hold x p -> IO (Subscriber x p)
320+newSubscriberHold :: (HasSpiderTimeline x, R.Patch p) => Hold x p -> IO (Subscriber x p)
320321newSubscriberHold h = return $ Subscriber
321322 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
322323 , subscriberInvalidateHeight = \_ -> return ()
323324 , subscriberRecalculateHeight = \_ -> return ()
324325 }
325326
326−newSubscriberFan :: GCompare k => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
327+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
327328newSubscriberFan subscribed = return $ Subscriber
328329 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
329330 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
330− tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
331+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
331332 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
332333 scheduleClear $ fanSubscribedOccurrence subscribed
333334 let f _ (Pair (Identity v) subsubs) = do
@@ -347,10 +348,10 @@ newSubscriberFan subscribed = return $ Subscriber
347348 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
348349 }
349350
350−newSubscriberSwitch :: SwitchSubscribed x a -> IO (Subscriber x a)
351+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
351352newSubscriberSwitch subscribed = return $ Subscriber
352353 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
353− tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
354+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
354355 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
355356 scheduleClear $ switchSubscribedOccurrence subscribed
356357 propagate a $ switchSubscribedSubscribers subscribed
@@ -367,15 +368,15 @@ newSubscriberSwitch subscribed = return $ Subscriber
367368 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
368369 }
369370
370−newSubscriberCoincidenceOuter :: CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
371+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
371372newSubscriberCoincidenceOuter subscribed = return $ Subscriber
372373 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
373− tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
374+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
374375 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
375− tracePropagate $ " outerHeight = " <> show outerHeight
376+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
376377 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
377− tracePropagate $ " isJust occ = " <> show (isJust occ)
378− tracePropagate $ " innerHeight = " <> show innerHeight
378+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
379+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
379380 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
380381 scheduleClear $ coincidenceSubscribedInnerParent subscribed
381382 case occ of
@@ -398,10 +399,10 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber
398399 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
399400 }
400401
401−newSubscriberCoincidenceInner :: CoincidenceSubscribed x a -> IO (Subscriber x a)
402+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
402403newSubscriberCoincidenceInner subscribed = return $ Subscriber
403404 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
404− tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
405+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
405406 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
406407 case occ of
407408 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
@@ -587,7 +588,7 @@ behaviorPull !p = Behavior $ do
587588 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
588589 return a
589590
590−behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)
591+behaviorDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Behavior x (R.PatchTarget p)
591592behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
592593
593594{-# INLINE readHoldTracked #-}
@@ -598,8 +599,8 @@ readHoldTracked h = do
598599 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
599600 return result
600601
601−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
602−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}
602+{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> BehaviorM x a #-}
603+{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}
603604readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
604605readBehaviorUntracked b = do
605606 holdInits <- getDeferralQueue
@@ -614,13 +615,13 @@ data Dynamic x p = Dynamic
614615 , dynamicUpdated :: !(Event x p)
615616 }
616617
617−dynamicHold :: Hold x p -> Dynamic x p
618+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
618619dynamicHold !h = Dynamic
619620 { dynamicCurrent = behaviorHold h
620621 , dynamicUpdated = eventHold h
621622 }
622623
623−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
624+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
624625dynamicHoldIdentity = dynamicHold
625626
626627dynamicConst :: R.PatchTarget p -> Dynamic x p
@@ -629,13 +630,13 @@ dynamicConst !a = Dynamic
629630 , dynamicUpdated = eventNever
630631 }
631632
632−dynamicDyn :: R.Patch p => Dyn x p -> Dynamic x p
633+dynamicDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Dynamic x p
633634dynamicDyn !d = Dynamic
634635 { dynamicCurrent = behaviorDyn d
635636 , dynamicUpdated = eventDyn d
636637 }
637638
638−dynamicDynIdentity :: Dyn x (Identity a) -> Dynamic x (Identity a)
639+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
639640dynamicDynIdentity = dynamicDyn
640641
641642--------------------------------------------------------------------------------
@@ -657,8 +658,7 @@ data Hold x p
657658 }
658659
659660data EventEnv x
660− = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)
661− , eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
661+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
662662 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
663663 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
664664 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
@@ -670,11 +670,11 @@ data EventEnv x
670670 }
671671
672672{-# INLINE runEventM #-}
673−runEventM :: EventM x a -> EventEnv x -> IO a
674−runEventM = runReaderT . unEventM
673+runEventM :: EventM x a -> IO a
674+runEventM = unEventM
675675
676−asksEventEnv :: (EventEnv x -> a) -> EventM x a
677−asksEventEnv = EventM . asks
676+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
677+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
678678
679679class MonadIO m => Defer a m where
680680 getDeferralQueue :: m (IORef [a])
@@ -685,58 +685,53 @@ defer a = do
685685 q <- getDeferralQueue
686686 liftIO $ modifyIORef' q (a:)
687687
688−instance Defer (SomeAssignment x) (EventM x) where
688+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
689689 {-# INLINE getDeferralQueue #-}
690690 getDeferralQueue = asksEventEnv eventEnvAssignments
691691
692−instance Defer (SomeHoldInit x) (EventM x) where
692+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
693693 {-# INLINE getDeferralQueue #-}
694694 getDeferralQueue = asksEventEnv eventEnvHoldInits
695695
696−instance Defer (SomeHoldInit x) (BehaviorM x) where
696+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (BehaviorM x) where
697697 {-# INLINE getDeferralQueue #-}
698698 getDeferralQueue = BehaviorM $ asks snd
699699
700−instance Defer (SomeMergeUpdate x) (EventM x) where
700+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
701701 {-# INLINE getDeferralQueue #-}
702702 getDeferralQueue = asksEventEnv eventEnvMergeUpdates
703703
704−instance Defer (SomeMergeInit x) (EventM x) where
704+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
705705 {-# INLINE getDeferralQueue #-}
706706 getDeferralQueue = asksEventEnv eventEnvMergeInits
707707
708−class HasCurrentHeight x m | m -> x where
708+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
709709 getCurrentHeight :: m Height
710710 scheduleMerge :: Height -> EventM x () -> m ()
711711
712−instance HasCurrentHeight x (EventM x) where
712+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
713713 {-# INLINE getCurrentHeight #-}
714− getCurrentHeight = EventM $ do
715− heightRef <- asks eventEnvCurrentHeight
714+ getCurrentHeight = do
715+ heightRef <- asksEventEnv eventEnvCurrentHeight
716716 liftIO $ readIORef heightRef
717717 {-# INLINE scheduleMerge #-}
718− scheduleMerge height subscribed = EventM $ do
719− delayedRef <- asks eventEnvDelayedMerges
718+ scheduleMerge height subscribed = do
719+ delayedRef <- asksEventEnv eventEnvDelayedMerges
720720 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
721721
722−class HasSpiderTimeline x m | m -> x where
722+class HasSpiderTimeline x where
723723 -- | Retrieve the current SpiderTimeline
724− askSpiderTimeline :: m (SpiderTimeline x)
725−
726−instance HasSpiderTimeline x (EventM x) where
727− {-# INLINE askSpiderTimeline #-}
728− askSpiderTimeline = asksEventEnv eventEnvSpiderTimeline
724+ spiderTimeline :: SpiderTimeline x
729725
730−instance HasSpiderTimeline x (SpiderHost x) where
731− {-# INLINE askSpiderTimeline #-}
732− askSpiderTimeline = SpiderHost ask
726+instance HasSpiderTimeline Global where
727+ spiderTimeline = globalSpiderTimeline
733728
734−putCurrentHeight :: Height -> EventM x ()
735−putCurrentHeight h = EventM $ do
736− heightRef <- asks eventEnvCurrentHeight
729+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
730+putCurrentHeight h = do
731+ heightRef <- asksEventEnv eventEnvCurrentHeight
737732 liftIO $ writeIORef heightRef $! h
738733
739−instance Defer SomeClear (EventM x) where
734+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
740735 {-# INLINE getDeferralQueue #-}
741736 getDeferralQueue = asksEventEnv eventEnvClears
742737
@@ -744,7 +739,7 @@ instance Defer SomeClear (EventM x) where
744739scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
745740scheduleClear r = defer $ SomeClear r
746741
747−instance Defer SomeRootClear (EventM x) where
742+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
748743 {-# INLINE getDeferralQueue #-}
749744 getDeferralQueue = asksEventEnv eventEnvRootClears
750745
@@ -752,13 +747,13 @@ instance Defer SomeRootClear (EventM x) where
752747scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
753748scheduleRootClear r = defer $ SomeRootClear r
754749
755−instance Defer (SomeResetCoincidence x) (EventM x) where
750+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
756751 {-# INLINE getDeferralQueue #-}
757752 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
758753
759754-- Note: hold cannot examine its event until after the phase is over
760−{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
761−{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}
755+{-# SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
756+{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}
762757hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)
763758hold v0 e = do
764759 valRef <- liftIO $ newIORef v0
@@ -780,7 +775,7 @@ hold v0 e = do
780775 return h
781776
782777{-# INLINE getHoldEventSubscription #-}
783−getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Hold x p -> m (EventSubscription x)
778+getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)
784779getHoldEventSubscription h = do
785780 ep <- liftIO $ readIORef $ holdParent h
786781 case ep of
@@ -876,14 +871,14 @@ data SomeMergeUpdate x = SomeMergeUpdate
876871newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
877872
878873-- EventM can do everything BehaviorM can, plus create holds
879−newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
874+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
880875
881876newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
882877
883878instance Defer (SomeHoldInit x) (ComputeM x) where
884879 getDeferralQueue = ComputeM ask
885880
886−{-# SPECIALIZE runComputeM :: ComputeM x a -> EventM x a #-}
881+{-# SPECIALIZE runComputeM :: HasSpiderTimeline x => ComputeM x a -> EventM x a #-}
887882runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
888883runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
889884
@@ -1001,20 +996,20 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1001996newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1002997newInvalidatorPull p = return $! InvalidatorPull p
1003998
1004−instance R.FunctorMaybe (Event x) where
999+instance HasSpiderTimeline x => R.FunctorMaybe (Event x) where
10051000 fmapMaybe f = push $ return . f
10061001
1007−instance Align (Event x) where
1002+instance HasSpiderTimeline x => Align (Event x) where
10081003 nil = eventNever
10091004 align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
10101005
10111006newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (R.PatchTarget p), Event x p) (Hold x p)) }
10121007
1013−newMapDyn :: (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1008+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
10141009newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
10151010
10161011--TODO: Avoid the duplication between this and R.zipDynWith
1017−zipDynWith :: (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1012+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
10181013zipDynWith f da db =
10191014 let eab = align (dynamicUpdated da) (dynamicUpdated db)
10201015 ec = flip push eab $ \o -> do
@@ -1033,7 +1028,7 @@ unsafeDyn :: BehaviorM x (R.PatchTarget p) -> Event x p -> Dyn x p
10331028unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
10341029 where x = (readV0, v')
10351030
1036−newJoinDyn :: Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)
1031+newJoinDyn :: HasSpiderTimeline x => Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)
10371032newJoinDyn d =
10381033 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
10391034 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -1049,14 +1044,14 @@ type ResultM = EventM
10491044unsafeNewIORef :: a -> b -> IORef b
10501045unsafeNewIORef _ b = unsafePerformIO $ newIORef b
10511046
1052−instance Functor (Event x) where
1047+instance HasSpiderTimeline x => Functor (Event x) where
10531048 fmap f = push $ return . Just . f
10541049
10551050instance Functor (Behavior x) where
10561051 fmap f = pull . fmap f . readBehaviorTracked
10571052
10581053{-# INLINABLE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
1059−push :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1054+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
10601055push f e = cacheEvent (pushCheap f e)
10611056{-
10621057push f e = eventPush $ Push
@@ -1078,22 +1073,22 @@ pull a = behaviorPull $ Pull
10781073 }
10791074
10801075{-# INLINABLE switch #-}
1081−switch :: Behavior x (Event x a) -> Event x a
1076+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
10821077switch a = eventSwitch $ Switch
10831078 { switchParent = a
10841079 , switchSubscribed = unsafeNewIORef a Nothing
10851080 }
10861081
1087−coincidence :: Event x (Event x a) -> Event x a
1082+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
10881083coincidence a = eventCoincidence $ Coincidence
10891084 { coincidenceParent = a
10901085 , coincidenceSubscribed = unsafeNewIORef a Nothing
10911086 }
10921087
10931088-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1094−run :: [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1089+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
10951090run roots after = do
1096− tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
1091+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
10971092 spiderTimeline <- SpiderHost ask
10981093 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do
10991094 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
@@ -1113,7 +1108,7 @@ run roots after = do
11131108 case IntMap.minViewWithKey delayed of
11141109 Nothing -> return ()
11151110 Just ((currentHeight, cur), future) -> do
1116− tracePropagate $ "Running height " ++ show currentHeight
1111+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
11171112 putCurrentHeight $ Height currentHeight
11181113 liftIO $ writeIORef delayedRef $! future
11191114 sequence_ cur
@@ -1121,10 +1116,10 @@ run roots after = do
11211116 go
11221117 putCurrentHeight maxBound
11231118 after
1124− tracePropagate "Done running an event frame"
1119+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
11251120 return result
11261121
1127−scheduleMerge' :: Height -> IORef Height -> EventM x () -> EventM x ()
1122+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
11281123scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
11291124 height <- liftIO $ readIORef heightRef
11301125 currentHeight <- getCurrentHeight
@@ -1166,23 +1161,23 @@ withIncreasedDepth :: m a -> m a
11661161withIncreasedDepth = id
11671162#endif
11681163
1169−type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)
1164+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
11701165
11711166{-# INLINE tracePropagate #-}
1172−tracePropagate :: (CanTrace x m) => String -> m ()
1173−tracePropagate = traceWhen debugPropagate
1167+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1168+tracePropagate p = traceWhen p debugPropagate
11741169
11751170{-# INLINE traceInvalidate #-}
11761171traceInvalidate :: String -> IO ()
11771172traceInvalidate = when debugInvalidate . liftIO . putStrLn
11781173
11791174{-# INLINE traceWhen #-}
1180−traceWhen :: (CanTrace x m) => Bool -> String -> m ()
1181−traceWhen b message = traceMWhen b $ return message
1175+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1176+traceWhen p b message = traceMWhen p b $ return message
11821177
11831178{-# INLINE traceMWhen #-}
1184−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
1185−traceMWhen b getMessage = when b $ do
1179+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1180+traceMWhen _ b getMessage = when b $ do
11861181 message <- getMessage
11871182#ifdef DEBUG
11881183 spiderTimeline <- askSpiderTimeline
@@ -1210,16 +1205,16 @@ listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupB
12101205#endif
12111206
12121207{-# INLINE propagateSubscriberHold #-}
1213−propagateSubscriberHold :: R.Patch p => Hold x p -> p -> EventM x ()
1208+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, R.Patch p) => Hold x p -> p -> EventM x ()
12141209propagateSubscriberHold h a = do
1215− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
1210+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
12161211 invalidators <- liftIO $ readIORef $ holdInvalidators h
12171212 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
12181213 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
12191214 case {-# SCC "apply" #-} R.apply a v of
12201215 Nothing -> return ()
12211216 Just v' -> do
1222− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1217+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
12231218 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
12241219 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
12251220 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1267,7 +1262,7 @@ zeroRef :: IORef Height
12671262zeroRef = unsafePerformIO $ newIORef zeroHeight
12681263
12691264type CanSubscribe x m =
1270− ( HasSpiderTimeline x m
1265+ ( HasSpiderTimeline x
12711266 , HasCurrentHeight x m
12721267 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
12731268 , Defer SomeClear m -- Wiping out event firings
@@ -1319,8 +1314,8 @@ cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscrib
13191314subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
13201315subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
13211316
1322−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) #-}
1323−getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
1317+{-# SPECIALIZE getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) #-}
1318+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
13241319getFanSubscribed k f sub = do
13251320 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
13261321 case mSubscribed of
@@ -1378,8 +1373,8 @@ subscribeFanSubscribed k subscribed sub = do
13781373 return sln
13791374 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
13801375
1381−{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) #-}
1382−getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1376+{-# SPECIALIZE getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) #-}
1377+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
13831378getSwitchSubscribed s sub = do
13841379 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
13851380 case mSubscribed of
@@ -1434,8 +1429,8 @@ cleanupSwitchSubscribed subscribed = do
14341429subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
14351430subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
14361431
1437−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) #-}
1438−getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1432+{-# SPECIALIZE getCoincidenceSubscribed :: HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) #-}
1433+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
14391434getCoincidenceSubscribed c sub = do
14401435 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
14411436 case mSubscribed of
@@ -1489,7 +1484,7 @@ subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a ->
14891484subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
14901485
14911486{-# INLINE merge #-}
1492−merge :: forall k x. GCompare k => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
1487+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
14931488merge d = cacheEvent $ Event $ \sub -> do
14941489 initialParents <- readBehaviorUntracked $ dynamicCurrent d
14951490 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
@@ -1525,7 +1520,7 @@ merge d = cacheEvent $ Event $ \sub -> do
15251520 { subscriberPropagate = \a -> do
15261521 oldM <- liftIO $ readIORef accumRef
15271522 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1528− tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1523+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
15291524 liftIO $ writeIORef accumRef $! newM
15301525 when (DMap.null oldM) $ do -- Only schedule the firing once
15311526 height <- liftIO $ readIORef heightRef
@@ -1599,7 +1594,7 @@ merge d = cacheEvent $ Event $ \sub -> do
15991594 defer $ SomeMergeInit $ do
16001595 let s = Subscriber
16011596 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1602− tracePropagate $ "SubscriberMerge/Change"
1597+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
16031598 defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight
16041599 , subscriberInvalidateHeight = \_ -> return ()
16051600 , subscriberRecalculateHeight = \_ -> return ()
@@ -1616,7 +1611,7 @@ merge d = cacheEvent $ Event $ \sub -> do
16161611
16171612newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
16181613
1619−fan :: GCompare k => Event x (DMap k Identity) -> EventSelector x k
1614+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
16201615fan e =
16211616 let f = Fan
16221617 { fanParent = e
@@ -1624,7 +1619,7 @@ fan e =
16241619 }
16251620 in EventSelector $ \k -> eventFan k f
16261621
1627−runHoldInits :: IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()
1622+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()
16281623runHoldInits holdInitRef mergeInitRef = do
16291624 holdInits <- liftIO $ readIORef holdInitRef
16301625 mergeInits <- liftIO $ readIORef mergeInitRef
@@ -1635,12 +1630,11 @@ runHoldInits holdInitRef mergeInitRef = do
16351630 mapM_ unSomeMergeInit mergeInits
16361631 runHoldInits holdInitRef mergeInitRef
16371632
1638−initHold :: SomeHoldInit x -> EventM x ()
1633+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
16391634initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
16401635
1641−-- | Run an event action outside of a frame
1642−runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1643−runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1636+newEventEnv :: IO (EventEnv x)
1637+newEventEnv = do
16441638 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
16451639 holdInitRef <- newIORef []
16461640 mergeUpdateRef <- newIORef []
@@ -1649,30 +1643,48 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
16491643 toClearRef <- newIORef []
16501644 toClearRootRef <- newIORef []
16511645 coincidenceInfosRef <- newIORef []
1652− delayedRef <- liftIO $ newIORef IntMap.empty
1653− let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1646+ delayedRef <- newIORef IntMap.empty
1647+ return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1648+
1649+clearEventEnv :: EventEnv x -> IO ()
1650+clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
1651+ writeIORef toAssignRef []
1652+ writeIORef holdInitRef []
1653+ writeIORef mergeUpdateRef []
1654+ writeIORef mergeInitRef []
1655+ writeIORef heightRef zeroHeight
1656+ writeIORef toClearRef []
1657+ writeIORef toClearRootRef []
1658+ writeIORef coincidenceInfosRef []
1659+ writeIORef delayedRef IntMap.empty
1660+
1661+-- | Run an event action outside of a frame
1662+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1663+runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1664+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
16541665 let go = do
16551666 result <- a
1656− runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1667+ runHoldInits (eventEnvHoldInits 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
16571668 return result
1658− result <- runEventM go env
1659− toClear <- readIORef toClearRef
1669+ result <- runEventM go
1670+ toClear <- readIORef $ eventEnvClears env
16601671 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1661− toClearRoot <- readIORef toClearRootRef
1672+ toClearRoot <- readIORef $ eventEnvRootClears env
16621673 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1663− toAssign <- readIORef toAssignRef
1674+ toAssign <- readIORef $ eventEnvAssignments env
16641675 toReconnectRef <- newIORef []
1665− coincidenceInfos <- readIORef coincidenceInfosRef
1676+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
16661677 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
16671678 writeIORef vRef v
16681679 when debugInvalidate $ putStrLn $ "Invalidating Hold"
16691680 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
1670− mergeUpdates <- readIORef mergeUpdateRef
1671− writeIORef mergeUpdateRef []
1681+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
1682+ writeIORef (eventEnvMergeUpdates env) []
16721683 when debugPropagate $ putStrLn "Updating merges"
1673− mergeSubscriptionsToKill <- flip runEventM env $ concat <$> mapM _someMergeUpdate_update mergeUpdates
1684+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
16741685 when debugPropagate $ putStrLn "Updating merges done"
16751686 toReconnect <- readIORef toReconnectRef
1687+ clearEventEnv env
16761688 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
16771689 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
16781690 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
@@ -1682,9 +1694,9 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
16821694 wi' <- mkWeakPtrWithDebug i "wi'"
16831695 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
16841696 writeIORef (switchSubscribedBehaviorParents subscribed) []
1685− writeIORef holdInitRef [] --TODO: Should we reuse this?
1686− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1687− runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
1697+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
1698+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
1699+ runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
16881700 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
16891701 sub <- newSubscriberSwitch subscribed
16901702 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
@@ -1815,9 +1827,10 @@ globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
18151827-- | Stores all global data relevant to a particular Spider timeline; only one
18161828-- value should exist for each type @x@
18171829data SpiderTimeline x = SpiderTimeline
1818− { _spiderTimeline_lock :: !(MVar ())
1830+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
1831+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
18191832#ifdef DEBUG
1820− , _spiderTimeline_depth :: !(IORef Int)
1833+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
18211834#endif
18221835 }
18231836type role SpiderTimeline nominal
@@ -1830,11 +1843,13 @@ instance GEq SpiderTimeline where
18301843unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)
18311844unsafeNewSpiderTimeline = do
18321845 lock <- newMVar ()
1846+ env <- newEventEnv
18331847#ifdef DEBUG
18341848 depthRef <- newIORef 0
18351849#endif
18361850 return $ SpiderTimeline
18371851 { _spiderTimeline_lock = lock
1852+ , _spiderTimeline_eventEnv = env
18381853#ifdef DEBUG
18391854 , _spiderTimeline_depth = depthRef
18401855#endif
@@ -1852,16 +1867,16 @@ newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applica
18521867
18531868newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
18541869
1855−instance Functor (R.Dynamic (SpiderTimeline x)) where
1870+instance HasSpiderTimeline x => Functor (R.Dynamic (SpiderTimeline x)) where
18561871 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
18571872
1858−instance Applicative (R.Dynamic (SpiderTimeline x)) where
1873+instance HasSpiderTimeline x => Applicative (R.Dynamic (SpiderTimeline x)) where
18591874 pure = SpiderDynamic . dynamicConst
18601875 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b
18611876 _ *> b = b
18621877 a <* _ = a
18631878
1864−instance Monad (R.Dynamic (SpiderTimeline x)) where
1879+instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where
18651880 {-# INLINE return #-}
18661881 return = pure
18671882 {-# INLINE (>>=) #-}
@@ -1871,7 +1886,7 @@ instance Monad (R.Dynamic (SpiderTimeline x)) where
18711886 {-# INLINE fail #-}
18721887 fail _ = error "Dynamic does not support 'fail'"
18731888
1874−instance R.Reflex (SpiderTimeline x) where
1889+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
18751890 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
18761891 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
18771892 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
@@ -1916,11 +1931,11 @@ instance R.Reflex (SpiderTimeline x) where
19161931 behaviorCoercion Coercion = Coercion
19171932 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
19181933
1919−instance R.MonadSample (SpiderTimeline x) (EventM x) where
1934+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (EventM x) where
19201935 {-# INLINABLE sample #-}
19211936 sample (SpiderBehavior b) = readBehaviorUntracked b
19221937
1923−instance R.MonadHold (SpiderTimeline x) (EventM x) where
1938+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (EventM x) where
19241939 {-# INLINABLE hold #-}
19251940 hold = holdSpiderEventM
19261941 {-# INLINABLE holdDyn #-}
@@ -1928,16 +1943,16 @@ instance R.MonadHold (SpiderTimeline x) (EventM x) where
19281943 {-# INLINABLE holdIncremental #-}
19291944 holdIncremental = holdIncrementalSpiderEventM
19301945
1931−holdSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)
1946+holdSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)
19321947holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
19331948
1934−holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)
1949+holdDynSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)
19351950holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
19361951
1937−holdIncrementalSpiderEventM :: R.Patch p => R.PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)
1952+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)
19381953holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e
19391954
1940−instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where
1955+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where
19411956 {-# INLINABLE hold #-}
19421957 hold v0 e = R.runHostFrame $ R.hold v0 e
19431958 {-# INLINABLE holdDyn #-}
@@ -1945,19 +1960,19 @@ instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where
19451960 {-# INLINABLE holdIncremental #-}
19461961 holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
19471962
1948−instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where
1963+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x) where
19491964 {-# INLINABLE sample #-}
19501965 sample = runFrame . readBehaviorUntracked . unSpiderBehavior
19511966
1952−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
1967+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
19531968 {-# INLINABLE sample #-}
19541969 sample = coerce . readBehaviorTracked . unSpiderBehavior
19551970
1956−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
1971+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
19571972 {-# INLINABLE sample #-}
19581973 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
19591974
1960−instance R.MonadHold (SpiderTimeline x) (SpiderPushM x) where
1975+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderPushM x) where
19611976 {-# INLINABLE hold #-}
19621977 hold v0 e = R.current <$> R.holdDyn v0 e
19631978 {-# INLINABLE holdDyn #-}
@@ -1972,7 +1987,7 @@ data SpiderEventHandle x a = SpiderEventHandle
19721987 , spiderEventHandleValue :: IORef (Maybe a)
19731988 }
19741989
1975−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
1990+instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
19761991 {-# INLINABLE subscribeEvent #-}
19771992 subscribeEvent e = SpiderHostFrame $ do
19781993 --TODO: Unsubscribe eventually (manually and/or with weak ref)
@@ -1989,12 +2004,12 @@ instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
19892004 , spiderEventHandleValue = val
19902005 }
19912006
1992−instance R.ReflexHost (SpiderTimeline x) where
2007+instance HasSpiderTimeline x => R.ReflexHost (SpiderTimeline x) where
19932008 type EventTrigger (SpiderTimeline x) = RootTrigger x
19942009 type EventHandle (SpiderTimeline x) = SpiderEventHandle x
19952010 type HostFrame (SpiderTimeline x) = SpiderHostFrame x
19962011
1997−instance R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where
2012+instance HasSpiderTimeline x => R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where
19982013 {-# NOINLINE readEvent #-}
19992014 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do
20002015 result <- readIORef $ spiderEventHandleValue h
@@ -2049,10 +2064,10 @@ instance Monad (SpiderHostFrame x) where
20492064 {-# INLINABLE fail #-}
20502065 fail s = SpiderHostFrame $ fail s
20512066
2052−instance R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2067+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
20532068 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
20542069
2055−instance R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2070+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
20562071 {-# INLINABLE hold #-}
20572072 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
20582073 {-# INLINABLE holdDyn #-}
@@ -2088,17 +2103,17 @@ instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
20882103 es <- newFanEventWithTriggerIO f
20892104 return $ R.EventSelector $ SpiderEvent . select es
20902105
2091−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2106+instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
20922107 {-# INLINABLE subscribeEvent #-}
20932108 subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent
20942109
20952110newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
20962111
2097−instance R.MonadSample (SpiderTimeline x) (ReadPhase x) where
2112+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (ReadPhase x) where
20982113 {-# INLINABLE sample #-}
20992114 sample = ReadPhase . R.sample
21002115
2101−instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where
2116+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (ReadPhase x) where
21022117 {-# INLINABLE hold #-}
21032118 hold v0 e = ReadPhase $ R.hold v0 e
21042119 {-# INLINABLE holdDyn #-}
@@ -2106,7 +2121,7 @@ instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where
21062121 {-# INLINABLE holdIncremental #-}
21072122 holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
21082123
2109−instance R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2124+instance HasSpiderTimeline x => R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
21102125 type ReadPhase (SpiderHost x) = ReadPhase x
21112126 fireEventsAndRead es (ReadPhase a) = run es a
21122127 runHostFrame = runFrame . runSpiderHostFrame