2bb2332 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Use a typeclass to insert the SpiderTimeline datastructure, rather than making EventM a ReaderT

2bb2332Ryan Trinkle10 years ago

src/Reflex/Spider.hs−1

compare with develop

unifiedsplit

@@ -9,7 +9,6 @@ module Reflex.Spider

9 , runSpiderHostForTimeline

10 , newSpiderTimeline

11 , withSpiderTimeline

12− , askSpiderTimeline

13 -- * Deprecated

12 -- * Deprecated

14 , SpiderEnv

13 , SpiderEnv

15 ) where

14 ) where

src/Reflex/Spider/Internal.hs+157−142

@@ -45,6 +45,7 @@ import Data.IORef

45import Data.List hiding (foldl')

46import Data.Maybe

47import Data.Monoid ((<>))

48+import Data.Proxy

48import Data.Some (Some)

49import Data.Some (Some)

49import qualified Data.Some as Some

50import qualified Data.Some as Some

50import Data.These

51import Data.These

@@ -185,7 +186,7 @@ newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (Even

185-- caching; if the computation function is very cheap, this is (much) more

186-- caching; if the computation function is very cheap, this is (much) more

186-- efficient than 'push'

187-- efficient than 'push'

187{-# INLINABLE pushCheap #-}

188{-# 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

189pushCheap f e = Event $ \sub -> do

190pushCheap f e = Event $ \sub -> do

190 (subscription, occ) <- subscribeAndRead e $ sub

191 (subscription, occ) <- subscribeAndRead e $ sub

191 { subscriberPropagate = \a -> do

192 { subscriberPropagate = \a -> do

@@ -210,7 +211,7 @@ data CacheSubscribed x a

210--there's only one subscriber, and then build our own WeakBag only when a second

211--there's only one subscriber, and then build our own WeakBag only when a second

211--subscriber joins

212--subscriber joins

212{-# INLINABLE cacheEvent #-}

213{-# INLINABLE cacheEvent #-}

213−cacheEvent :: Event x a -> Event x a

214+cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

214cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do

215cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do

215 let !mSubscribedRef = unsafeNewIORef e Nothing

216 let !mSubscribedRef = unsafeNewIORef e Nothing

216 mSubscribed <- liftIO $ readIORef mSubscribedRef

217 mSubscribed <- liftIO $ readIORef mSubscribedRef

@@ -271,19 +272,19 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed

271eventNever :: Event x a

272eventNever :: Event x a

272eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

273eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

273

274

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

275eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

276eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

276

277

277−eventSwitch :: Switch x a -> Event x a

278+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

278eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

279eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

279

280

280−eventCoincidence :: Coincidence x a -> Event x a

281+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

281eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

282eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

282

283

283−eventHold :: Hold x p -> Event x p

284+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

284eventHold !h = Event $ subscribeHoldEvent h

285eventHold !h = Event $ subscribeHoldEvent h

285

286

286−eventDyn :: R.Patch p => Dyn x p -> Event x p

287+eventDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Event x p

287eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

288eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

288

289

289{-# INLINE subscribeCoincidenceInner #-}

290{-# INLINE subscribeCoincidenceInner #-}

@@ -316,18 +317,18 @@ data Subscriber x a = Subscriber

316-- The result is also evaluated to WHNF, since forcing a thunk invalidates

317-- The result is also evaluated to WHNF, since forcing a thunk invalidates

317-- the weak pointer to it in some cases.

318-- the weak pointer to it in some cases.

318

319

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)

320newSubscriberHold h = return $ Subscriber

321newSubscriberHold h = return $ Subscriber

321 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

322 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

322 , subscriberInvalidateHeight = \_ -> return ()

323 , subscriberInvalidateHeight = \_ -> return ()

323 , subscriberRecalculateHeight = \_ -> return ()

324 , subscriberRecalculateHeight = \_ -> return ()

324 }

325 }

325

326

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))

327newSubscriberFan subscribed = return $ Subscriber

328newSubscriberFan subscribed = return $ Subscriber

328 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

329 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

329 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

330 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"

331 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

332 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

332 scheduleClear $ fanSubscribedOccurrence subscribed

333 scheduleClear $ fanSubscribedOccurrence subscribed

333 let f _ (Pair (Identity v) subsubs) = do

334 let f _ (Pair (Identity v) subsubs) = do

@@ -347,10 +348,10 @@ newSubscriberFan subscribed = return $ Subscriber

347 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

348 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

348 }

349 }

349

350

350−newSubscriberSwitch :: SwitchSubscribed x a -> IO (Subscriber x a)

351+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

351newSubscriberSwitch subscribed = return $ Subscriber

352newSubscriberSwitch subscribed = return $ Subscriber

352 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

353 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

353− tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed

354+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed

354 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

355 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

355 scheduleClear $ switchSubscribedOccurrence subscribed

356 scheduleClear $ switchSubscribedOccurrence subscribed

356 propagate a $ switchSubscribedSubscribers subscribed

357 propagate a $ switchSubscribedSubscribers subscribed

@@ -367,15 +368,15 @@ newSubscriberSwitch subscribed = return $ Subscriber

367 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

368 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

368 }

369 }

369

370

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))

371newSubscriberCoincidenceOuter subscribed = return $ Subscriber

372newSubscriberCoincidenceOuter subscribed = return $ Subscriber

372 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

373 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

373− tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

374+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

374 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

375 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

375− tracePropagate $ " outerHeight = " <> show outerHeight

376+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

376 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

377 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

377− tracePropagate $ " isJust occ = " <> show (isJust occ)

378+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

378− tracePropagate $ " innerHeight = " <> show innerHeight

379+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

379 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

380 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

380 scheduleClear $ coincidenceSubscribedInnerParent subscribed

381 scheduleClear $ coincidenceSubscribedInnerParent subscribed

381 case occ of

382 case occ of

@@ -398,10 +399,10 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber

398 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

399 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

399 }

400 }

400

401

401−newSubscriberCoincidenceInner :: CoincidenceSubscribed x a -> IO (Subscriber x a)

402+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

402newSubscriberCoincidenceInner subscribed = return $ Subscriber

403newSubscriberCoincidenceInner subscribed = return $ Subscriber

403 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

404 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

404− tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed

405+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed

405 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

406 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

406 case occ of

407 case occ of

407 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

408 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

@@ -587,7 +588,7 @@ behaviorPull !p = Behavior $ do

587 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

588 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

588 return a

589 return a

589

590

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)

591behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d

592behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d

592

593

593{-# INLINE readHoldTracked #-}

594{-# INLINE readHoldTracked #-}

@@ -598,8 +599,8 @@ readHoldTracked h = do

598 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

599 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

599 return result

600 return result

600

601

601−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}

602+{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> BehaviorM x a #-}

602−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}

603+{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}

603readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

604readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

604readBehaviorUntracked b = do

605readBehaviorUntracked b = do

605 holdInits <- getDeferralQueue

606 holdInits <- getDeferralQueue

@@ -614,13 +615,13 @@ data Dynamic x p = Dynamic

614 , dynamicUpdated :: !(Event x p)

615 , dynamicUpdated :: !(Event x p)

615 }

616 }

616

617

617−dynamicHold :: Hold x p -> Dynamic x p

618+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p

618dynamicHold !h = Dynamic

619dynamicHold !h = Dynamic

619 { dynamicCurrent = behaviorHold h

620 { dynamicCurrent = behaviorHold h

620 , dynamicUpdated = eventHold h

621 , dynamicUpdated = eventHold h

621 }

622 }

622

623

623−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

624+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

624dynamicHoldIdentity = dynamicHold

625dynamicHoldIdentity = dynamicHold

625

626

626dynamicConst :: R.PatchTarget p -> Dynamic x p

627dynamicConst :: R.PatchTarget p -> Dynamic x p

@@ -629,13 +630,13 @@ dynamicConst !a = Dynamic

629 , dynamicUpdated = eventNever

630 , dynamicUpdated = eventNever

630 }

631 }

631

632

632−dynamicDyn :: R.Patch p => Dyn x p -> Dynamic x p

633+dynamicDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Dynamic x p

633dynamicDyn !d = Dynamic

634dynamicDyn !d = Dynamic

634 { dynamicCurrent = behaviorDyn d

635 { dynamicCurrent = behaviorDyn d

635 , dynamicUpdated = eventDyn d

636 , dynamicUpdated = eventDyn d

636 }

637 }

637

638

638−dynamicDynIdentity :: Dyn x (Identity a) -> Dynamic x (Identity a)

639+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

639dynamicDynIdentity = dynamicDyn

640dynamicDynIdentity = dynamicDyn

640

641

641--------------------------------------------------------------------------------

642--------------------------------------------------------------------------------

@@ -657,8 +658,7 @@ data Hold x p

657 }

658 }

658

659

659data EventEnv x

660data EventEnv x

660− = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)

661− , eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

661+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

662 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

663 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

664 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

@@ -670,11 +670,11 @@ data EventEnv x

670 }

671

672{-# INLINE runEventM #-}

673−runEventM :: EventM x a -> EventEnv x -> IO a

673+runEventM :: EventM x a -> IO a

674−runEventM = runReaderT . unEventM

674+runEventM = unEventM

675

676−asksEventEnv :: (EventEnv x -> a) -> EventM x a

676+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

677−asksEventEnv = EventM . asks

677+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)

678

679class MonadIO m => Defer a m where

680 getDeferralQueue :: m (IORef [a])

@@ -685,58 +685,53 @@ defer a = do

685 q <- getDeferralQueue

686 liftIO $ modifyIORef' q (a:)

687

688−instance Defer (SomeAssignment x) (EventM x) where

688+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where

689 {-# INLINE getDeferralQueue #-}

690 getDeferralQueue = asksEventEnv eventEnvAssignments

691

692−instance Defer (SomeHoldInit x) (EventM x) where

692+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where

693 {-# INLINE getDeferralQueue #-}

694 getDeferralQueue = asksEventEnv eventEnvHoldInits

695

696−instance Defer (SomeHoldInit x) (BehaviorM x) where

696+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (BehaviorM x) where

697 {-# INLINE getDeferralQueue #-}

698 getDeferralQueue = BehaviorM $ asks snd

699

700−instance Defer (SomeMergeUpdate x) (EventM x) where

700+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where

701 {-# INLINE getDeferralQueue #-}

702 getDeferralQueue = asksEventEnv eventEnvMergeUpdates

703

704−instance Defer (SomeMergeInit x) (EventM x) where

704+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where

705 {-# INLINE getDeferralQueue #-}

706 getDeferralQueue = asksEventEnv eventEnvMergeInits

707

708−class HasCurrentHeight x m | m -> x where

708+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where

709 getCurrentHeight :: m Height

710 scheduleMerge :: Height -> EventM x () -> m ()

711

712−instance HasCurrentHeight x (EventM x) where

712+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

713 {-# INLINE getCurrentHeight #-}

714− getCurrentHeight = EventM $ do

714+ getCurrentHeight = do

715− heightRef <- asks eventEnvCurrentHeight

715+ heightRef <- asksEventEnv eventEnvCurrentHeight

716 liftIO $ readIORef heightRef

717 {-# INLINE scheduleMerge #-}

718− scheduleMerge height subscribed = EventM $ do

718+ scheduleMerge height subscribed = do

719− delayedRef <- asks eventEnvDelayedMerges

719+ delayedRef <- asksEventEnv eventEnvDelayedMerges

720 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

721

722−class HasSpiderTimeline x m | m -> x where

722+class HasSpiderTimeline x where

723 -- | Retrieve the current SpiderTimeline

724− askSpiderTimeline :: m (SpiderTimeline x)

724+ spiderTimeline :: SpiderTimeline x

725−

726−instance HasSpiderTimeline x (EventM x) where

727− {-# INLINE askSpiderTimeline #-}

728− askSpiderTimeline = asksEventEnv eventEnvSpiderTimeline

729

725

730−instance HasSpiderTimeline x (SpiderHost x) where

726+instance HasSpiderTimeline Global where

731− {-# INLINE askSpiderTimeline #-}

727+ spiderTimeline = globalSpiderTimeline

732− askSpiderTimeline = SpiderHost ask

733

728

734−putCurrentHeight :: Height -> EventM x ()

729+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()

735−putCurrentHeight h = EventM $ do

730+putCurrentHeight h = do

736− heightRef <- asks eventEnvCurrentHeight

731+ heightRef <- asksEventEnv eventEnvCurrentHeight

737 liftIO $ writeIORef heightRef $! h

732 liftIO $ writeIORef heightRef $! h

738

733

739−instance Defer SomeClear (EventM x) where

734+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

740 {-# INLINE getDeferralQueue #-}

735 {-# INLINE getDeferralQueue #-}

741 getDeferralQueue = asksEventEnv eventEnvClears

736 getDeferralQueue = asksEventEnv eventEnvClears

742

737

@@ -744,7 +739,7 @@ instance Defer SomeClear (EventM x) where

744scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

739scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

745scheduleClear r = defer $ SomeClear r

740scheduleClear r = defer $ SomeClear r

746

741

747−instance Defer SomeRootClear (EventM x) where

742+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

748 {-# INLINE getDeferralQueue #-}

743 {-# INLINE getDeferralQueue #-}

749 getDeferralQueue = asksEventEnv eventEnvRootClears

744 getDeferralQueue = asksEventEnv eventEnvRootClears

750

745

@@ -752,13 +747,13 @@ instance Defer SomeRootClear (EventM x) where

752scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()

747scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()

753scheduleRootClear r = defer $ SomeRootClear r

748scheduleRootClear r = defer $ SomeRootClear r

754

749

755−instance Defer (SomeResetCoincidence x) (EventM x) where

750+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

756 {-# INLINE getDeferralQueue #-}

751 {-# INLINE getDeferralQueue #-}

757 getDeferralQueue = asksEventEnv eventEnvResetCoincidences

752 getDeferralQueue = asksEventEnv eventEnvResetCoincidences

758

753

759-- Note: hold cannot examine its event until after the phase is over

754-- 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) #-}

755+{-# SPECIALIZE hold :: (HasSpiderTimeline x, 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) #-}

756+{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}

762hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)

757hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)

763hold v0 e = do

758hold v0 e = do

764 valRef <- liftIO $ newIORef v0

759 valRef <- liftIO $ newIORef v0

@@ -780,7 +775,7 @@ hold v0 e = do

780 return h

775 return h

781

776

782{-# INLINE getHoldEventSubscription #-}

777{-# 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)

784getHoldEventSubscription h = do

779getHoldEventSubscription h = do

785 ep <- liftIO $ readIORef $ holdParent h

780 ep <- liftIO $ readIORef $ holdParent h

786 case ep of

781 case ep of

@@ -876,14 +871,14 @@ data SomeMergeUpdate x = SomeMergeUpdate

876newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

871newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

877

872

878-- EventM can do everything BehaviorM can, plus create holds

873-- 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

880

875

881newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

876newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

882

877

883instance Defer (SomeHoldInit x) (ComputeM x) where

878instance Defer (SomeHoldInit x) (ComputeM x) where

884 getDeferralQueue = ComputeM ask

879 getDeferralQueue = ComputeM ask

885

880

886−{-# SPECIALIZE runComputeM :: ComputeM x a -> EventM x a #-}

881+{-# SPECIALIZE runComputeM :: HasSpiderTimeline x => ComputeM x a -> EventM x a #-}

887runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

882runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

888runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

883runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

889

884

@@ -1001,20 +996,20 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1001newInvalidatorPull :: Pull x a -> IO (Invalidator x)

996newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1002newInvalidatorPull p = return $! InvalidatorPull p

997newInvalidatorPull p = return $! InvalidatorPull p

1003

998

1004−instance R.FunctorMaybe (Event x) where

999+instance HasSpiderTimeline x => R.FunctorMaybe (Event x) where

1005 fmapMaybe f = push $ return . f

1000 fmapMaybe f = push $ return . f

1006

1001

1007−instance Align (Event x) where

1002+instance HasSpiderTimeline x => Align (Event x) where

1008 nil = eventNever

1003 nil = eventNever

1009 align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]

1004 align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]

1010

1005

1011newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (R.PatchTarget p), Event x p) (Hold x p)) }

1006newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (R.PatchTarget p), Event x p) (Hold x p)) }

1012

1007

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)

1014newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1009newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1015

1010

1016--TODO: Avoid the duplication between this and R.zipDynWith

1011--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)

1018zipDynWith f da db =

1013zipDynWith f da db =

1019 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1014 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1020 ec = flip push eab $ \o -> do

1015 ec = flip push eab $ \o -> do

@@ -1033,7 +1028,7 @@ unsafeDyn :: BehaviorM x (R.PatchTarget p) -> Event x p -> Dyn x p

1033unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1028unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1034 where x = (readV0, v')

1029 where x = (readV0, v')

1035

1030

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)

1037newJoinDyn d =

1032newJoinDyn d =

1038 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1033 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1039 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

1034 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -1049,14 +1044,14 @@ type ResultM = EventM

1049unsafeNewIORef :: a -> b -> IORef b

1044unsafeNewIORef :: a -> b -> IORef b

1050unsafeNewIORef _ b = unsafePerformIO $ newIORef b

1045unsafeNewIORef _ b = unsafePerformIO $ newIORef b

1051

1046

1052−instance Functor (Event x) where

1047+instance HasSpiderTimeline x => Functor (Event x) where

1053 fmap f = push $ return . Just . f

1048 fmap f = push $ return . Just . f

1054

1049

1055instance Functor (Behavior x) where

1050instance Functor (Behavior x) where

1056 fmap f = pull . fmap f . readBehaviorTracked

1051 fmap f = pull . fmap f . readBehaviorTracked

1057

1052

1058{-# INLINABLE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly

1053{-# 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

1060push f e = cacheEvent (pushCheap f e)

1055push f e = cacheEvent (pushCheap f e)

1061{-

1056{-

1062push f e = eventPush $ Push

1057push f e = eventPush $ Push

@@ -1078,22 +1073,22 @@ pull a = behaviorPull $ Pull

1078 }

1073 }

1079

1074

1080{-# INLINABLE switch #-}

1075{-# INLINABLE switch #-}

1081−switch :: Behavior x (Event x a) -> Event x a

1076+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1082switch a = eventSwitch $ Switch

1077switch a = eventSwitch $ Switch

1083 { switchParent = a

1078 { switchParent = a

1084 , switchSubscribed = unsafeNewIORef a Nothing

1079 , switchSubscribed = unsafeNewIORef a Nothing

1085 }

1080 }

1086

1081

1087−coincidence :: Event x (Event x a) -> Event x a

1082+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1088coincidence a = eventCoincidence $ Coincidence

1083coincidence a = eventCoincidence $ Coincidence

1089 { coincidenceParent = a

1084 { coincidenceParent = a

1090 , coincidenceSubscribed = unsafeNewIORef a Nothing

1085 , coincidenceSubscribed = unsafeNewIORef a Nothing

1091 }

1086 }

1092

1087

1093-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

1088-- 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

1095run roots after = do

1090run 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"

1097 spiderTimeline <- SpiderHost ask

1092 spiderTimeline <- SpiderHost ask

1098 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do

1093 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do

1099 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1094 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

@@ -1113,7 +1108,7 @@ run roots after = do

1113 case IntMap.minViewWithKey delayed of

1108 case IntMap.minViewWithKey delayed of

1114 Nothing -> return ()

1109 Nothing -> return ()

1115 Just ((currentHeight, cur), future) -> do

1110 Just ((currentHeight, cur), future) -> do

1116− tracePropagate $ "Running height " ++ show currentHeight

1111+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight

1117 putCurrentHeight $ Height currentHeight

1112 putCurrentHeight $ Height currentHeight

1118 liftIO $ writeIORef delayedRef $! future

1113 liftIO $ writeIORef delayedRef $! future

1119 sequence_ cur

1114 sequence_ cur

@@ -1121,10 +1116,10 @@ run roots after = do

1121 go

1116 go

1122 putCurrentHeight maxBound

1117 putCurrentHeight maxBound

1123 after

1118 after

1124− tracePropagate "Done running an event frame"

1119+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"

1125 return result

1120 return result

1126

1121

1127−scheduleMerge' :: Height -> IORef Height -> EventM x () -> EventM x ()

1122+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()

1128scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1123scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1129 height <- liftIO $ readIORef heightRef

1124 height <- liftIO $ readIORef heightRef

1130 currentHeight <- getCurrentHeight

1125 currentHeight <- getCurrentHeight

@@ -1166,23 +1161,23 @@ withIncreasedDepth :: m a -> m a

1166withIncreasedDepth = id

1161withIncreasedDepth = id

1167#endif

1162#endif

1168

1163

1169−type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)

1164+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1170

1165

1171{-# INLINE tracePropagate #-}

1166{-# INLINE tracePropagate #-}

1172−tracePropagate :: (CanTrace x m) => String -> m ()

1167+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1173−tracePropagate = traceWhen debugPropagate

1168+tracePropagate p = traceWhen p debugPropagate

1174

1169

1175{-# INLINE traceInvalidate #-}

1170{-# INLINE traceInvalidate #-}

1176traceInvalidate :: String -> IO ()

1171traceInvalidate :: String -> IO ()

1177traceInvalidate = when debugInvalidate . liftIO . putStrLn

1172traceInvalidate = when debugInvalidate . liftIO . putStrLn

1178

1173

1179{-# INLINE traceWhen #-}

1174{-# INLINE traceWhen #-}

1180−traceWhen :: (CanTrace x m) => Bool -> String -> m ()

1175+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1181−traceWhen b message = traceMWhen b $ return message

1176+traceWhen p b message = traceMWhen p b $ return message

1182

1177

1183{-# INLINE traceMWhen #-}

1178{-# INLINE traceMWhen #-}

1184−traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()

1179+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1185−traceMWhen b getMessage = when b $ do

1180+traceMWhen _ b getMessage = when b $ do

1186 message <- getMessage

1181 message <- getMessage

1187#ifdef DEBUG

1182#ifdef DEBUG

1188 spiderTimeline <- askSpiderTimeline

1183 spiderTimeline <- askSpiderTimeline

@@ -1210,16 +1205,16 @@ listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupB

1210#endif

1205#endif

1211

1206

1212{-# INLINE propagateSubscriberHold #-}

1207{-# 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 ()

1214propagateSubscriberHold h a = do

1209propagateSubscriberHold h a = do

1215− {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do

1210+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1216 invalidators <- liftIO $ readIORef $ holdInvalidators h

1211 invalidators <- liftIO $ readIORef $ holdInvalidators h

1217 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1212 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1218 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1213 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1219 case {-# SCC "apply" #-} R.apply a v of

1214 case {-# SCC "apply" #-} R.apply a v of

1220 Nothing -> return ()

1215 Nothing -> return ()

1221 Just v' -> do

1216 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

1223 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1218 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1224 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1219 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1225 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1220 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1267,7 +1262,7 @@ zeroRef :: IORef Height

1267zeroRef = unsafePerformIO $ newIORef zeroHeight

1262zeroRef = unsafePerformIO $ newIORef zeroHeight

1268

1263

1269type CanSubscribe x m =

1264type CanSubscribe x m =

1270− ( HasSpiderTimeline x m

1265+ ( HasSpiderTimeline x

1271 , HasCurrentHeight x m

1266 , HasCurrentHeight x m

1272 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1267 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1273 , Defer SomeClear m -- Wiping out event firings

1268 , Defer SomeClear m -- Wiping out event firings

@@ -1319,8 +1314,8 @@ cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscrib

1319subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1314subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1320subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1315subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1321

1316

1322−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (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) #-}

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)

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)

1324getFanSubscribed k f sub = do

1319getFanSubscribed k f sub = do

1325 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1320 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1326 case mSubscribed of

1321 case mSubscribed of

@@ -1378,8 +1373,8 @@ subscribeFanSubscribed k subscribed sub = do

1378 return sln

1373 return sln

1379 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1374 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1380

1375

1381−{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (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) #-}

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)

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)

1383getSwitchSubscribed s sub = do

1378getSwitchSubscribed s sub = do

1384 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1379 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1385 case mSubscribed of

1380 case mSubscribed of

@@ -1434,8 +1429,8 @@ cleanupSwitchSubscribed subscribed = do

1434subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1429subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1435subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1430subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1436

1431

1437−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (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) #-}

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)

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)

1439getCoincidenceSubscribed c sub = do

1434getCoincidenceSubscribed c sub = do

1440 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1435 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1441 case mSubscribed of

1436 case mSubscribed of

@@ -1489,7 +1484,7 @@ subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a ->

1489subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1484subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1490

1485

1491{-# INLINE merge #-}

1486{-# 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)

1493merge d = cacheEvent $ Event $ \sub -> do

1488merge d = cacheEvent $ Event $ \sub -> do

1494 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1489 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1495 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1490 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

@@ -1525,7 +1520,7 @@ merge d = cacheEvent $ Event $ \sub -> do

1525 { subscriberPropagate = \a -> do

1520 { subscriberPropagate = \a -> do

1526 oldM <- liftIO $ readIORef accumRef

1521 oldM <- liftIO $ readIORef accumRef

1527 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1522 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)

1529 liftIO $ writeIORef accumRef $! newM

1524 liftIO $ writeIORef accumRef $! newM

1530 when (DMap.null oldM) $ do -- Only schedule the firing once

1525 when (DMap.null oldM) $ do -- Only schedule the firing once

1531 height <- liftIO $ readIORef heightRef

1526 height <- liftIO $ readIORef heightRef

@@ -1599,7 +1594,7 @@ merge d = cacheEvent $ Event $ \sub -> do

1599 defer $ SomeMergeInit $ do

1594 defer $ SomeMergeInit $ do

1600 let s = Subscriber

1595 let s = Subscriber

1601 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1596 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1602− tracePropagate $ "SubscriberMerge/Change"

1597+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1603 defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1598 defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1604 , subscriberInvalidateHeight = \_ -> return ()

1599 , subscriberInvalidateHeight = \_ -> return ()

1605 , subscriberRecalculateHeight = \_ -> return ()

1600 , subscriberRecalculateHeight = \_ -> return ()

@@ -1616,7 +1611,7 @@ merge d = cacheEvent $ Event $ \sub -> do

1616

1611

1617newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

1612newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

1618

1613

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

1620fan e =

1615fan e =

1621 let f = Fan

1616 let f = Fan

1622 { fanParent = e

1617 { fanParent = e

@@ -1624,7 +1619,7 @@ fan e =

1624 }

1619 }

1625 in EventSelector $ \k -> eventFan k f

1620 in EventSelector $ \k -> eventFan k f

1626

1621

1627−runHoldInits :: IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1622+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1628runHoldInits holdInitRef mergeInitRef = do

1623runHoldInits holdInitRef mergeInitRef = do

1629 holdInits <- liftIO $ readIORef holdInitRef

1624 holdInits <- liftIO $ readIORef holdInitRef

1630 mergeInits <- liftIO $ readIORef mergeInitRef

1625 mergeInits <- liftIO $ readIORef mergeInitRef

@@ -1635,12 +1630,11 @@ runHoldInits holdInitRef mergeInitRef = do

1635 mapM_ unSomeMergeInit mergeInits

1630 mapM_ unSomeMergeInit mergeInits

1636 runHoldInits holdInitRef mergeInitRef

1631 runHoldInits holdInitRef mergeInitRef

1637

1632

1638−initHold :: SomeHoldInit x -> EventM x ()

1633+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()

1639initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1634initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1640

1635

1641−-- | Run an event action outside of a frame

1636+newEventEnv :: IO (EventEnv x)

1642−runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1637+newEventEnv = do

1643−runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

1644 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

1638 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

1645 holdInitRef <- newIORef []

1639 holdInitRef <- newIORef []

1646 mergeUpdateRef <- newIORef []

1640 mergeUpdateRef <- newIORef []

@@ -1649,30 +1643,48 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

1649 toClearRef <- newIORef []

1643 toClearRef <- newIORef []

1650 toClearRootRef <- newIORef []

1644 toClearRootRef <- newIORef []

1651 coincidenceInfosRef <- newIORef []

1645 coincidenceInfosRef <- newIORef []

1652− delayedRef <- liftIO $ newIORef IntMap.empty

1646+ delayedRef <- newIORef IntMap.empty

1653− let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

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)

1654 let go = do

1665 let go = do

1655 result <- a

1666 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

1657 return result

1668 return result

1658− result <- runEventM go env

1669+ result <- runEventM go

1659− toClear <- readIORef toClearRef

1670+ toClear <- readIORef $ eventEnvClears env

1660 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

1671 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

1661− toClearRoot <- readIORef toClearRootRef

1672+ toClearRoot <- readIORef $ eventEnvRootClears env

1662 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1673 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1663− toAssign <- readIORef toAssignRef

1674+ toAssign <- readIORef $ eventEnvAssignments env

1664 toReconnectRef <- newIORef []

1675 toReconnectRef <- newIORef []

1665− coincidenceInfos <- readIORef coincidenceInfosRef

1676+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

1666 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

1677 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

1667 writeIORef vRef v

1678 writeIORef vRef v

1668 when debugInvalidate $ putStrLn $ "Invalidating Hold"

1679 when debugInvalidate $ putStrLn $ "Invalidating Hold"

1669 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1680 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1670− mergeUpdates <- readIORef mergeUpdateRef

1681+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env

1671− writeIORef mergeUpdateRef []

1682+ writeIORef (eventEnvMergeUpdates env) []

1672 when debugPropagate $ putStrLn "Updating merges"

1683 when debugPropagate $ putStrLn "Updating merges"

1673− mergeSubscriptionsToKill <- flip runEventM env $ concat <$> mapM _someMergeUpdate_update mergeUpdates

1684+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

1674 when debugPropagate $ putStrLn "Updating merges done"

1685 when debugPropagate $ putStrLn "Updating merges done"

1675 toReconnect <- readIORef toReconnectRef

1686 toReconnect <- readIORef toReconnectRef

1687+ clearEventEnv env

1676 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1688 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1677 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

1689 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

1678 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

1690 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

@@ -1682,9 +1694,9 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

1682 wi' <- mkWeakPtrWithDebug i "wi'"

1694 wi' <- mkWeakPtrWithDebug i "wi'"

1683 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'

1695 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'

1684 writeIORef (switchSubscribedBehaviorParents subscribed) []

1696 writeIORef (switchSubscribedBehaviorParents subscribed) []

1685− writeIORef holdInitRef [] --TODO: Should we reuse this?

1697+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?

1686− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef

1698+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env

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

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

1688 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1700 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1689 sub <- newSubscriberSwitch subscribed

1701 sub <- newSubscriberSwitch subscribed

1690 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

1702 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

1815-- | Stores all global data relevant to a particular Spider timeline; only one

1827-- | Stores all global data relevant to a particular Spider timeline; only one

1816-- value should exist for each type @x@

1828-- value should exist for each type @x@

1817data SpiderTimeline x = SpiderTimeline

1829data SpiderTimeline x = SpiderTimeline

1818− { _spiderTimeline_lock :: !(MVar ())

1830+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

1831+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

1819#ifdef DEBUG

1832#ifdef DEBUG

1820− , _spiderTimeline_depth :: !(IORef Int)

1833+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

1821#endif

1834#endif

1822 }

1835 }

1823type role SpiderTimeline nominal

1836type role SpiderTimeline nominal

@@ -1830,11 +1843,13 @@ instance GEq SpiderTimeline where

1830unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)

1843unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)

1831unsafeNewSpiderTimeline = do

1844unsafeNewSpiderTimeline = do

1832 lock <- newMVar ()

1845 lock <- newMVar ()

1846+ env <- newEventEnv

1833#ifdef DEBUG

1847#ifdef DEBUG

1834 depthRef <- newIORef 0

1848 depthRef <- newIORef 0

1835#endif

1849#endif

1836 return $ SpiderTimeline

1850 return $ SpiderTimeline

1837 { _spiderTimeline_lock = lock

1851 { _spiderTimeline_lock = lock

1852+ , _spiderTimeline_eventEnv = env

1838#ifdef DEBUG

1853#ifdef DEBUG

1839 , _spiderTimeline_depth = depthRef

1854 , _spiderTimeline_depth = depthRef

1840#endif

1855#endif

@@ -1852,16 +1867,16 @@ newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applica

1852

1867

1853newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1868newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1854

1869

1855−instance Functor (R.Dynamic (SpiderTimeline x)) where

1870+instance HasSpiderTimeline x => Functor (R.Dynamic (SpiderTimeline x)) where

1856 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

1871 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

1857

1872

1858−instance Applicative (R.Dynamic (SpiderTimeline x)) where

1873+instance HasSpiderTimeline x => Applicative (R.Dynamic (SpiderTimeline x)) where

1859 pure = SpiderDynamic . dynamicConst

1874 pure = SpiderDynamic . dynamicConst

1860 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b

1875 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b

1861 _ *> b = b

1876 _ *> b = b

1862 a <* _ = a

1877 a <* _ = a

1863

1878

1864−instance Monad (R.Dynamic (SpiderTimeline x)) where

1879+instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where

1865 {-# INLINE return #-}

1880 {-# INLINE return #-}

1866 return = pure

1881 return = pure

1867 {-# INLINE (>>=) #-}

1882 {-# INLINE (>>=) #-}

@@ -1871,7 +1886,7 @@ instance Monad (R.Dynamic (SpiderTimeline x)) where

1871 {-# INLINE fail #-}

1886 {-# INLINE fail #-}

1872 fail _ = error "Dynamic does not support 'fail'"

1887 fail _ = error "Dynamic does not support 'fail'"

1873

1888

1874−instance R.Reflex (SpiderTimeline x) where

1889+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1875 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

1890 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

1876 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

1891 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

1877 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

1892 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

1916 behaviorCoercion Coercion = Coercion

1931 behaviorCoercion Coercion = Coercion

1917 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

1932 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

1918

1933

1919−instance R.MonadSample (SpiderTimeline x) (EventM x) where

1934+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (EventM x) where

1920 {-# INLINABLE sample #-}

1935 {-# INLINABLE sample #-}

1921 sample (SpiderBehavior b) = readBehaviorUntracked b

1936 sample (SpiderBehavior b) = readBehaviorUntracked b

1922

1937

1923−instance R.MonadHold (SpiderTimeline x) (EventM x) where

1938+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (EventM x) where

1924 {-# INLINABLE hold #-}

1939 {-# INLINABLE hold #-}

1925 hold = holdSpiderEventM

1940 hold = holdSpiderEventM

1926 {-# INLINABLE holdDyn #-}

1941 {-# INLINABLE holdDyn #-}

@@ -1928,16 +1943,16 @@ instance R.MonadHold (SpiderTimeline x) (EventM x) where

1928 {-# INLINABLE holdIncremental #-}

1943 {-# INLINABLE holdIncremental #-}

1929 holdIncremental = holdIncrementalSpiderEventM

1944 holdIncremental = holdIncrementalSpiderEventM

1930

1945

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)

1932holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1947holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1933

1948

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)

1935holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1950holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1936

1951

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)

1938holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

1953holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

1939

1954

1940−instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where

1955+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where

1941 {-# INLINABLE hold #-}

1956 {-# INLINABLE hold #-}

1942 hold v0 e = R.runHostFrame $ R.hold v0 e

1957 hold v0 e = R.runHostFrame $ R.hold v0 e

1943 {-# INLINABLE holdDyn #-}

1958 {-# INLINABLE holdDyn #-}

@@ -1945,19 +1960,19 @@ instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where

1945 {-# INLINABLE holdIncremental #-}

1960 {-# INLINABLE holdIncremental #-}

1946 holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e

1961 holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e

1947

1962

1948−instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where

1963+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x) where

1949 {-# INLINABLE sample #-}

1964 {-# INLINABLE sample #-}

1950 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

1965 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

1951

1966

1952−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

1967+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

1953 {-# INLINABLE sample #-}

1968 {-# INLINABLE sample #-}

1954 sample = coerce . readBehaviorTracked . unSpiderBehavior

1969 sample = coerce . readBehaviorTracked . unSpiderBehavior

1955

1970

1956−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

1971+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

1957 {-# INLINABLE sample #-}

1972 {-# INLINABLE sample #-}

1958 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

1973 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

1959

1974

1960−instance R.MonadHold (SpiderTimeline x) (SpiderPushM x) where

1975+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderPushM x) where

1961 {-# INLINABLE hold #-}

1976 {-# INLINABLE hold #-}

1962 hold v0 e = R.current <$> R.holdDyn v0 e

1977 hold v0 e = R.current <$> R.holdDyn v0 e

1963 {-# INLINABLE holdDyn #-}

1978 {-# INLINABLE holdDyn #-}

@@ -1972,7 +1987,7 @@ data SpiderEventHandle x a = SpiderEventHandle

1972 , spiderEventHandleValue :: IORef (Maybe a)

1987 , spiderEventHandleValue :: IORef (Maybe a)

1973 }

1988 }

1974

1989

1975−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

1990+instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

1976 {-# INLINABLE subscribeEvent #-}

1991 {-# INLINABLE subscribeEvent #-}

1977 subscribeEvent e = SpiderHostFrame $ do

1992 subscribeEvent e = SpiderHostFrame $ do

1978 --TODO: Unsubscribe eventually (manually and/or with weak ref)

1993 --TODO: Unsubscribe eventually (manually and/or with weak ref)

@@ -1989,12 +2004,12 @@ instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

1989 , spiderEventHandleValue = val

2004 , spiderEventHandleValue = val

1990 }

2005 }

1991

2006

1992−instance R.ReflexHost (SpiderTimeline x) where

2007+instance HasSpiderTimeline x => R.ReflexHost (SpiderTimeline x) where

1993 type EventTrigger (SpiderTimeline x) = RootTrigger x

2008 type EventTrigger (SpiderTimeline x) = RootTrigger x

1994 type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2009 type EventHandle (SpiderTimeline x) = SpiderEventHandle x

1995 type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2010 type HostFrame (SpiderTimeline x) = SpiderHostFrame x

1996

2011

1997−instance R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where

2012+instance HasSpiderTimeline x => R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where

1998 {-# NOINLINE readEvent #-}

2013 {-# NOINLINE readEvent #-}

1999 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2014 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2000 result <- readIORef $ spiderEventHandleValue h

2015 result <- readIORef $ spiderEventHandleValue h

@@ -2049,10 +2064,10 @@ instance Monad (SpiderHostFrame x) where

2049 {-# INLINABLE fail #-}

2064 {-# INLINABLE fail #-}

2050 fail s = SpiderHostFrame $ fail s

2065 fail s = SpiderHostFrame $ fail s

2051

2066

2052−instance R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2067+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2053 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2068 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2054

2069

2055−instance R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2070+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2056 {-# INLINABLE hold #-}

2071 {-# INLINABLE hold #-}

2057 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2072 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2058 {-# INLINABLE holdDyn #-}

2073 {-# INLINABLE holdDyn #-}

@@ -2088,17 +2103,17 @@ instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2088 es <- newFanEventWithTriggerIO f

2103 es <- newFanEventWithTriggerIO f

2089 return $ R.EventSelector $ SpiderEvent . select es

2104 return $ R.EventSelector $ SpiderEvent . select es

2090

2105

2091−instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

2106+instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

2092 {-# INLINABLE subscribeEvent #-}

2107 {-# INLINABLE subscribeEvent #-}

2093 subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

2108 subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

2094

2109

2095newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2110newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2096

2111

2097−instance R.MonadSample (SpiderTimeline x) (ReadPhase x) where

2112+instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (ReadPhase x) where

2098 {-# INLINABLE sample #-}

2113 {-# INLINABLE sample #-}

2099 sample = ReadPhase . R.sample

2114 sample = ReadPhase . R.sample

2100

2115

2101−instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where

2116+instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (ReadPhase x) where

2102 {-# INLINABLE hold #-}

2117 {-# INLINABLE hold #-}

2103 hold v0 e = ReadPhase $ R.hold v0 e

2118 hold v0 e = ReadPhase $ R.hold v0 e

2104 {-# INLINABLE holdDyn #-}

2119 {-# INLINABLE holdDyn #-}

@@ -2106,7 +2121,7 @@ instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where

2106 {-# INLINABLE holdIncremental #-}

2121 {-# INLINABLE holdIncremental #-}

2107 holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e

2122 holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e

2108

2123

2109−instance R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

2124+instance HasSpiderTimeline x => R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

2110 type ReadPhase (SpiderHost x) = ReadPhase x

2125 type ReadPhase (SpiderHost x) = ReadPhase x

2111 fireEventsAndRead es (ReadPhase a) = run es a

2126 fireEventsAndRead es (ReadPhase a) = run es a

2112 runHostFrame = runFrame . runSpiderHostFrame

2127 runHostFrame = runFrame . runSpiderHostFrame