8438020 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Factor out asksEventEnv

8438020Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+13−10

compare with develop

unifiedsplit

@@ -673,6 +673,9 @@ data EventEnv x

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

674runEventM = runReaderT . unEventM

675

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

677+asksEventEnv = EventM . asks

678+

676class MonadIO m => Defer a m where

679class MonadIO m => Defer a m where

677 getDeferralQueue :: m (IORef [a])

680 getDeferralQueue :: m (IORef [a])

678

681

@@ -684,11 +687,11 @@ defer a = do

684

687

685instance Defer (SomeAssignment x) (EventM x) where

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

686 {-# INLINE getDeferralQueue #-}

689 {-# INLINE getDeferralQueue #-}

687− getDeferralQueue = EventM $ asks eventEnvAssignments

690+ getDeferralQueue = asksEventEnv eventEnvAssignments

688

691

689instance Defer (SomeHoldInit x) (EventM x) where

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

690 {-# INLINE getDeferralQueue #-}

693 {-# INLINE getDeferralQueue #-}

691− getDeferralQueue = EventM $ asks eventEnvHoldInits

694+ getDeferralQueue = asksEventEnv eventEnvHoldInits

692

695

693instance Defer (SomeHoldInit x) (BehaviorM x) where

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

694 {-# INLINE getDeferralQueue #-}

697 {-# INLINE getDeferralQueue #-}

@@ -696,11 +699,11 @@ instance Defer (SomeHoldInit x) (BehaviorM x) where

696

699

697instance Defer (SomeMergeUpdate x) (EventM x) where

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

698 {-# INLINE getDeferralQueue #-}

701 {-# INLINE getDeferralQueue #-}

699− getDeferralQueue = EventM $ asks eventEnvMergeUpdates

702+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates

700

703

701instance Defer (SomeMergeInit x) (EventM x) where

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

702 {-# INLINE getDeferralQueue #-}

705 {-# INLINE getDeferralQueue #-}

703− getDeferralQueue = EventM $ asks eventEnvMergeInits

706+ getDeferralQueue = asksEventEnv eventEnvMergeInits

704

707

705class HasCurrentHeight x m | m -> x where

708class HasCurrentHeight x m | m -> x where

706 getCurrentHeight :: m Height

709 getCurrentHeight :: m Height

@@ -722,7 +725,7 @@ class HasSpiderTimeline x m | m -> x where

722

725

723instance HasSpiderTimeline x (EventM x) where

726instance HasSpiderTimeline x (EventM x) where

724 {-# INLINE askSpiderTimeline #-}

727 {-# INLINE askSpiderTimeline #-}

725− askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline

728+ askSpiderTimeline = asksEventEnv eventEnvSpiderTimeline

726

729

727instance HasSpiderTimeline x (SpiderHost x) where

730instance HasSpiderTimeline x (SpiderHost x) where

728 {-# INLINE askSpiderTimeline #-}

731 {-# INLINE askSpiderTimeline #-}

@@ -735,7 +738,7 @@ putCurrentHeight h = EventM $ do

735

738

736instance Defer SomeClear (EventM x) where

739instance Defer SomeClear (EventM x) where

737 {-# INLINE getDeferralQueue #-}

740 {-# INLINE getDeferralQueue #-}

738− getDeferralQueue = EventM $ asks eventEnvClears

741+ getDeferralQueue = asksEventEnv eventEnvClears

739

742

740{-# INLINE scheduleClear #-}

743{-# INLINE scheduleClear #-}

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

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

@@ -743,7 +746,7 @@ scheduleClear r = defer $ SomeClear r

743

746

744instance Defer SomeRootClear (EventM x) where

747instance Defer SomeRootClear (EventM x) where

745 {-# INLINE getDeferralQueue #-}

748 {-# INLINE getDeferralQueue #-}

746− getDeferralQueue = EventM $ asks eventEnvRootClears

749+ getDeferralQueue = asksEventEnv eventEnvRootClears

747

750

748{-# INLINE scheduleRootClear #-}

751{-# INLINE scheduleRootClear #-}

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

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

@@ -751,7 +754,7 @@ scheduleRootClear r = defer $ SomeRootClear r

751

754

752instance Defer (SomeResetCoincidence x) (EventM x) where

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

753 {-# INLINE getDeferralQueue #-}

756 {-# INLINE getDeferralQueue #-}

754− getDeferralQueue = EventM $ asks eventEnvResetCoincidences

757+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences

755

758

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

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

757{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

760{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

@@ -873,7 +876,7 @@ data SomeMergeUpdate x = SomeMergeUpdate

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

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

874

877

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

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

876−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

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

877

880

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

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

879

882

@@ -1104,7 +1107,7 @@ run roots after = do

1104 else return Nothing

1107 else return Nothing

1105 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do

1108 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do

1106 propagate a subscribersRef

1109 propagate a subscribersRef

1107− delayedRef <- EventM $ asks eventEnvDelayedMerges

1110+ delayedRef <- asksEventEnv eventEnvDelayedMerges

1108 let go = do

1111 let go = do

1109 delayed <- liftIO $ readIORef delayedRef

1112 delayed <- liftIO $ readIORef delayedRef

1110 case IntMap.minViewWithKey delayed of

1113 case IntMap.minViewWithKey delayed of