rhine-gloss 1.7 → 1.8
raw patch · 4 files changed
+51/−46 lines, 4 filesdep −monad-scheduledep ~basedep ~rhine
Dependencies removed: monad-schedule
Dependency ranges changed: base, rhine
Files
- ChangeLog.md +6/−0
- rhine-gloss.cabal +4/−5
- src/FRP/Rhine/Gloss/IO.hs +31/−30
- src/FRP/Rhine/Gloss/Pure.hs +10/−11
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for rhine-gloss +## 1.8++* Remove dependency on `monad-schedule` because of performance problems.+ See https://github.com/turion/rhine/issues/377.+* Revert scheduling in the `IO` backend to `IO`.+ ## 1.4 * Use `FreeAsyncT` in the gloss IO backend for fairer concurrency.
rhine-gloss.cabal view
@@ -1,7 +1,7 @@ -- Initial rhine-gloss.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: rhine-gloss-version: 1.7+version: 1.8 synopsis: Gloss backend for Rhine description: This package provides a simple wrapper for the `gloss` library,@@ -38,11 +38,10 @@ build-depends: automaton,- base >=4.16 && <4.22,+ base >=4.18 && <4.22, gloss >=1.12, mmorph >=1.1,- monad-schedule >=1.6,- rhine ^>=1.7,+ rhine ^>=1.8, transformers >=0.5 hs-source-dirs: src@@ -57,7 +56,7 @@ main-is: Main.hs ghc-options: -threaded build-depends:- base >=4.16 && <4.22,+ base >=4.18 && <4.22, rhine-gloss default-language: Haskell2010
src/FRP/Rhine/Gloss/IO.hs view
@@ -47,9 +47,8 @@ -- gloss import Graphics.Gloss.Interface.IO.Game --- monad-schedule-import Control.Monad.Schedule.Class-import Control.Monad.Schedule.FreeAsync+-- automaton+import Data.Automaton.Schedule -- rhine import FRP.Rhine@@ -68,30 +67,32 @@ , timeRef :: IORef (Seconds Float) } -{- | Effects in the gloss backend+{- | Effects in the gloss backend. -* Wraps the concurrent variables needed for communication with the @gloss@ backend.-* Adds the 'FreeAsyncT' concurrency layer for fairer scheduling+Wraps the concurrent variables needed for communication with the @gloss@ backend. -} newtype GlossConcT m a = GlossConcT- {unGlossConcT :: ReaderT GlossEnv (FreeAsyncT m) a}+ {unGlossConcT :: ReaderT GlossEnv m a} deriving (Functor, Applicative, Monad, MonadIO) -- | When @gloss@ is the only effect you are using, use this monad to simplify your type signatures. type GlossConc = GlossConcT IO instance MonadTrans GlossConcT where- lift = GlossConcT . lift . lift+ lift = GlossConcT . lift -- FIXME MFunctor & MMonad instances pending https://github.com/HeinrichApfelmus/operational/pull/28/ -- | Remove the 'GlossConcT' transformer by explicitly providing an environment. runGlossConcT :: (MonadIO m) => GlossConcT m a -> GlossEnv -> m a-runGlossConcT ma env = runFreeAsyncT $ runReaderT (unGlossConcT ma) env+runGlossConcT ma = runReaderT (unGlossConcT ma) -- | Disregards scheduling capabilities of @m@, as it uses 'FreeAsync'.-instance (MonadIO m) => MonadSchedule (GlossConcT m) where- schedule actions = GlossConcT $ fmap (second $ map GlossConcT) $ schedule $ unGlossConcT <$> actions+instance (MonadIO m, MonadSchedule m) => MonadSchedule (GlossConcT m) where+ schedule =+ fmap (hoistS unGlossConcT)+ >>> schedule+ >>> hoistS GlossConcT withPicRef :: (MonadIO m) =>@@ -126,14 +127,14 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where type Time GlossEventClockIO = Seconds Float type Tag GlossEventClockIO = Event- initClock _ = return (constM getEvent, 0)+ initClock _ = pure (constM getEvent, 0) where getEvent = do GlossEnv {eventVar, timeRef} <- GlossConcT ask- event <- GlossConcT $ lift $ asyncMVar eventVar liftIO $ do+ event <- takeMVar eventVar time <- readIORef timeRef- return (time, event)+ pure (time, event) {-# INLINE initClock #-} instance GetClockProxy GlossEventClockIO@@ -149,11 +150,11 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where type Time GlossSimClockIO = Seconds Float type Tag GlossSimClockIO = ()- initClock _ = return (constM getTime &&& arr (const ()), 0)+ initClock _ = pure (constM getTime &&& arr (const ()), 0) where getTime = GlossConcT $ do GlossEnv {timeVar} <- ask- lift $ asyncMVar timeVar+ liftIO $ takeMVar timeVar {-# INLINE initClock #-} instance GetClockProxy GlossSimClockIO@@ -187,7 +188,7 @@ void $ timeout 100000 $ -- timeout in case noone is listening for events putMVar eventVar event- return vars+ pure vars simStep diffTime vars@GlossEnv {timeVar, timeRef} = do time <- readIORef timeRef let !time' = time + Seconds diffTime@@ -195,18 +196,18 @@ -- which can lead to non-monotonous time updates. tryPutMVar timeVar time' writeIORef timeRef time'- return vars+ pure vars void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep- return vars+ pure vars {- | Apply this to supply the 'GlossConcT' effect.- Creates a new thread in which @gloss@ is run,- and feeds the clocks 'GlossEventClockIO' and 'GlossSimClockIO'.+ Creates a new thread in which @gloss@ is run,+ and feeds the clocks 'GlossEventClockIO' and 'GlossSimClockIO'. - Usually, this function is applied to the result of 'flow',- so you can handle all occurring effects as needed.- If you only use @gloss@ in your whole signal network,- you can use 'flowGlossIO' instead.+ Usually, this function is applied to the result of 'flow',+ so you can handle all occurring effects as needed.+ If you only use @gloss@ in your whole signal network,+ you can use 'flowGlossIO' instead. -} launchInGlossThread :: (MonadIO m) =>@@ -218,7 +219,7 @@ runGlossConcT glossLoop vars {- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,- and reactimate in the foreground.+ and reactimate in the foreground. -} flowGlossIO :: ( MonadIO m@@ -233,13 +234,13 @@ flowGlossIO settings = launchInGlossThread settings . flow {- | Apply this wrapper to your clock type @cl@ in order to escape the 'GlossConcT' transformer.- The resulting clock will be in @m@, not 'GlossConcT m' anymore.- Typically, @m@ will have the 'MonadIO' constraint.+ The resulting clock will be in @m@, not 'GlossConcT m' anymore.+ Typically, @m@ will have the 'MonadIO' constraint. -} type RunGlossEnvClock m cl = HoistClock (GlossConcT m) m cl {- | Apply to a gloss clock to remove a 'GlossConcT' layer.- You will have to have initialized a 'GlossEnv', for example by calling 'launchGlossThread'.+ You will have to have initialized a 'GlossEnv', for example by calling 'launchGlossThread'. -} runGlossEnvClock :: (MonadIO m) =>@@ -266,7 +267,7 @@ glossConcTClock unhoistedClock = HoistClock { unhoistedClock- , monadMorphism = GlossConcT . lift . freeAsync+ , monadMorphism = GlossConcT . liftIO } {- | Lift an 'IO' clock to 'GlossConc'.
src/FRP/Rhine/Gloss/Pure.hs view
@@ -19,7 +19,8 @@ currentEvent, flowGloss, flowGlossClSF,-) where+)+where -- base import qualified Control.Category as Category@@ -30,11 +31,9 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer.Strict --- monad-schedule-import Control.Monad.Schedule.Class-import Control.Monad.Schedule.Yield- -- automaton+import Data.Automaton.Schedule (MonadSchedule (..))+import Data.Automaton.Schedule.Trans (SkipT, runSkipT, skip) import Data.Automaton.Trans.Except (performOnFirstSample) import qualified Data.Automaton.Trans.Reader as AutomatonReader import qualified Data.Automaton.Trans.Writer as AutomatonWriter@@ -48,12 +47,12 @@ -- * @gloss@ effects -- | A pure monad in which all effects caused by the @gloss@ backend take place.-newtype GlossM a = GlossM {unGlossM :: YieldT (ReaderT (Seconds Float, Maybe Event) (Writer Picture)) a}+newtype GlossM a = GlossM {unGlossM :: SkipT (ReaderT (Seconds Float, Maybe Event) (Writer Picture)) a} deriving (Functor, Applicative, Monad) -- Would have liked to make this a derived instance, but for some reason deriving gets thrown off by the newtype instance MonadSchedule GlossM where- schedule actions = fmap (fmap (fmap GlossM)) $ GlossM $ schedule $ fmap unGlossM actions+ schedule = fmap (hoistS unGlossM) >>> schedule >>> hoistS GlossM -- | Add a picture to the canvas. paint :: Picture -> GlossM ()@@ -72,7 +71,7 @@ -- * Clocks {- | The overall clock of a pure @rhine@ 'ClSF' that can be run by @gloss@.- It ticks both on events (@tag = Just Event@) and simulation steps (@tag = Nothing@).+ It ticks both on events (@tag = Just Event@) and simulation steps (@tag = Nothing@). -} data GlossClock = GlossClock @@ -82,7 +81,7 @@ instance Clock GlossM GlossClock where type Time GlossClock = Seconds Float type Tag GlossClock = Maybe Event- initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumN *** Category.id), 0)+ initClock _ = pure (constM (GlossM (skip >> lift ask)) >>> (sumN *** Category.id), 0) {-# INLINE initClock #-} instance GetClockProxy GlossClock@@ -99,7 +98,7 @@ type GlossClSF = ClSF GlossM GlossClock () Picture {- | Observe whether there was an event this tick,- and which one.+ and which one. -} currentEvent :: ClSF GlossM GlossClock () (Maybe Event) currentEvent = tagS@@ -126,7 +125,7 @@ play display backgroundColor stepsPerSecond (worldAutomaton, Blank) getPic handleEvent simStep where worldAutomaton :: WorldAutomaton- worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine+ worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runSkipT . unGlossM) $ performOnFirstSample $ eraseClock rhine stepWith :: (Float, Maybe Event) -> (WorldAutomaton, Picture) -> (WorldAutomaton, Picture) stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = runIdentity $ stepAutomaton automaton ((Seconds diff, eventMaybe), ()) in (automaton', picture) getPic (_, pic) = pic