b82c2e7 · reflex · git.iko.soy

git.iko.soy/reflex

Add newBehavior

commitb82c2e7ef9d5e2f9a0f61fae608ab14b4265262a authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 5 Aug 2018, 17:48 (8 years ago) parentb55c607

4 files changed+48−4

compare with develop

unifiedsplit

src/Reflex/Host/Class.hs+12 src/Reflex/PerformEvent/Base.hs+6 src/Reflex/Profiled.hs+5 src/Reflex/Spider/Internal.hs+25−4

src/Reflex/Host/Class.hs+12

@@ -21,6 +21,7 @@ module Reflex.Host.Class

2121 , MonadSubscribeEvent (..)

2222 , MonadReadEvent (..)

2323 , MonadReflexCreateTrigger (..)

24+ , MonadReflexCreateBehavior (..)

2425 , MonadReflexHost (..)

2526 , fireEvents

2627 , newEventWithTriggerRef

@@ -48,12 +49,14 @@ import Data.GADT.Compare

4849-- represented by @t@.

4950class ( Reflex t

5051 , MonadReflexCreateTrigger t (HostFrame t)

52+ , MonadReflexCreateBehavior t (HostFrame t)

5153 , MonadSample t (HostFrame t)

5254 , MonadHold t (HostFrame t)

5355 , MonadFix (HostFrame t)

5456 , MonadSubscribeEvent t (HostFrame t)

5557 ) => ReflexHost t where

5658 type EventTrigger t :: * -> *

59+ type BehaviorInvalidator t :: *

5760 type EventHandle t :: * -> *

5861 type HostFrame t :: * -> *

5962

@@ -107,6 +110,15 @@ class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where

107110 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)

108111 newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)

109112

113+-- | A monad where new events feed from external sources can be created.

114+class (Applicative m, Monad m) => MonadReflexCreateBehavior t m | m -> t where

115+ -- | Creates a root 'Behavior' (one that is not based on any Event or other

116+ -- Behavior).

117+ newBehavior :: (BehaviorInvalidator t -> IO a) -> m (Behavior t a)

118+ -- | Invalidate a root 'Behavior', effective for all logical times greater

119+ -- than the current time.

120+ invalidateBehavior :: BehaviorInvalidator t -> m ()

121+

110122-- | 'MonadReflexHost' designates monads that can run reflex frames.

111123class ( ReflexHost t

112124 , MonadReflexCreateTrigger t m

src/Reflex/PerformEvent/Base.hs+6

@@ -114,6 +114,12 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

114114 {-# INLINABLE newFanEventWithTrigger #-}

115115 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

116116

117+instance ReflexHost t => MonadReflexCreateBehavior t (PerformEventT t m) where

118+ {-# INLINABLE newBehavior #-}

119+ newBehavior = PerformEventT . lift . newBehavior

120+ {-# INLINABLE invalidateBehavior #-}

121+ invalidateBehavior = PerformEventT . lift . invalidateBehavior

122+

117123-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the

118124-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run

119125-- at the appropriate time.

src/Reflex/Profiled.hs+5

@@ -185,6 +185,10 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimel

185185 es <- lift $ newFanEventWithTrigger f

186186 return $ EventSelector $ \k -> coerce $ select es k

187187

188+instance MonadReflexCreateBehavior t m => MonadReflexCreateBehavior (ProfiledTimeline t) (ProfiledM m) where

189+ newBehavior getValue = fmap Behavior_Profiled $ lift $ newBehavior $ coerce getValue

190+ invalidateBehavior = lift . invalidateBehavior

191+

188192instance MonadReader r m => MonadReader r (ProfiledM m) where

189193 ask = lift ask

190194 local f (ProfiledM a) = ProfiledM $ local f a

@@ -193,6 +197,7 @@ instance MonadReader r m => MonadReader r (ProfiledM m) where

193197instance ReflexHost t => ReflexHost (ProfiledTimeline t) where

194198 type EventTrigger (ProfiledTimeline t) = EventTrigger t

195199 type EventHandle (ProfiledTimeline t) = EventHandle t

200+ type BehaviorInvalidator (ProfiledTimeline t) = BehaviorInvalidator t

196201 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)

197202

198203instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where

src/Reflex/Spider/Internal.hs+25−4

@@ -788,6 +788,7 @@ data EventEnv x

788788 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

789789 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

790790 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

791+ , eventEnvToReconnect :: !(IORef [SomeSwitchSubscribed x])

791792 }

792793

793794{-# INLINE runEventM #-}

@@ -1212,6 +1213,9 @@ coincidence a = eventCoincidence $ Coincidence

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

12131214run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

12141215run roots after = do

1216+ --TDOO: This is kind of a hack: if we detect that `toReconnect` is not empty, which means we've invalidated behaviors between the last frame and this one

1217+ toReconnect <- liftIO $ readIORef $ eventEnvToReconnect $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

1218+ when (not $ null toReconnect) $ runFrame $ pure ()

12151219 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

12161220 t <- SpiderHost ask

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

@@ -2056,10 +2060,11 @@ newEventEnv = do

20562060 toClearRootRef <- newIORef []

20572061 coincidenceInfosRef <- newIORef []

20582062 delayedRef <- newIORef IntMap.empty

2059− return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef

2063+ toReconnectRef <- newIORef []

2064+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef toReconnectRef

20602065

20612066clearEventEnv :: EventEnv x -> IO ()

2062−clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

2067+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef toReconnectRef) = do

20632068 writeIORef toAssignRef []

20642069 writeIORef holdInitRef []

20652070 writeIORef dynInitRef []

@@ -2071,6 +2076,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

20712076 writeIORef toClearRootRef []

20722077 writeIORef coincidenceInfosRef []

20732078 writeIORef delayedRef IntMap.empty

2079+ writeIORef toReconnectRef []

20742080

20752081-- | Run an event action outside of a frame

20762082runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

@@ -2088,7 +2094,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

20882094 toClearRoot <- readIORef $ eventEnvRootClears env

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

20902096 toAssign <- readIORef $ eventEnvAssignments env

2091− toReconnectRef <- newIORef []

2097+ let toReconnectRef = eventEnvToReconnect env

20922098 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

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

20942100 writeIORef vRef v

@@ -2394,6 +2400,7 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTim

23942400

23952401instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

23962402 type EventTrigger (SpiderTimeline x) = RootTrigger x

2403+ type BehaviorInvalidator (SpiderTimeline x) = Maybe (Weak (Invalidator x))

23972404 type EventHandle (SpiderTimeline x) = SpiderEventHandle x

23982405 type HostFrame (SpiderTimeline x) = SpiderHostFrame x

23992406

@@ -2410,12 +2417,26 @@ instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHo

24102417 es <- newFanEventWithTriggerIO f

24112418 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

24122419

2420+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateBehavior (SpiderTimeline x) (SpiderHost x) where

2421+ newBehavior getValue = pure $ SpiderBehavior $ pull $ do

2422+ !invalidator <- askInvalidator

2423+ BehaviorM $ lift $ getValue invalidator

2424+ invalidateBehavior mi = forM_ mi $ \i -> do

2425+ liftIO $ void $ invalidate (eventEnvToReconnect $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)) [i]

2426+

24132427instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

24142428 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

24152429 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

24162430 es <- newFanEventWithTriggerIO f

24172431 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

24182432

2433+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateBehavior (SpiderTimeline x) (SpiderHostFrame x) where

2434+ newBehavior getValue = pure $ SpiderBehavior $ pull $ do

2435+ !invalidator <- askInvalidator

2436+ BehaviorM $ lift $ getValue invalidator

2437+ invalidateBehavior mi = forM_ mi $ \i -> do

2438+ liftIO $ void $ invalidate (eventEnvToReconnect $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)) [i]

2439+

24192440instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

24202441 {-# INLINABLE subscribeEvent #-}

24212442 subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

@@ -2558,7 +2579,7 @@ instance Monad (SpiderHost x) where

25582579-- | Run an action affecting the global Spider timeline; this will be guarded by

25592580-- a mutex for that timeline

25602581runSpiderHost :: SpiderHost Global a -> IO a

2561−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2582+runSpiderHost a = runSpiderHostForTimeline a globalSpiderTimelineEnv

25622583

25632584-- | Run an action affecting a given Spider timeline; this will be guarded by a

25642585-- mutex for that timeline