rhine-gloss 0.9 → 1.0

raw patch · 6 files changed

+85/−82 lines, 6 filesdep +monad-scheduledep ~rhinePVP ok

version bump matches the API change (PVP)

Dependencies added: monad-schedule

Dependency ranges changed: rhine

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Main.hs +4/−4
• rhine-gloss.cabal +4/−3
• src/FRP/Rhine/Gloss/IO.hs +38/−27
• src/FRP/Rhine/Gloss/Pure.hs +32/−25
• src/FRP/Rhine/Gloss/Pure/Combined.hs +2/−23

@@ -1,5 +1,10 @@ # Revision history for rhine-gloss +## 1.0++* Removed schedules. See the [page about changes in version 1](/version1.md).+* Simplified `gloss` backends. Renamed `launchGlossThread` to `launchInGlossThread`.+ ## 0.7.0  * Reworked `gloss` backends.

@@ -28,8 +28,8 @@   putStrLn "Please choose between the pure (1), the pure combined (2), and the IO backend (3):"   n <- readLn   case n of-    1 -> flowGloss defaultSettings pureClSF-    2 -> flowGlossCombined defaultSettings pureRhine+    1 -> flowGlossClSF defaultSettings pureClSF+    2 -> flowGloss defaultSettings pureRhine     3 -> flowGlossIO defaultSettings ioRhine     _ -> error "Invalid input" @@ -39,7 +39,7 @@ {- | Run the gears simulation with the pure backend with two subsystems,    one at the rate of events, one at the rate of simulation. -}-pureRhine = tagS @@ glossEventClock >-- collect -@- glossSchedule --> sim >-> arrMCl paintAll @@ glossSimulationClock+pureRhine = tagS @@ glossEventClock >-- collect --> sim >-> arrMCl paintAll @@ glossSimulationClock  -- | Run the gears simulation with the 'IO' backend.-ioRhine = tagS @@ GlossEventClockIO >-- collect -@- glossConcurrently --> sim >-> arrMCl paintAllIO @@ GlossSimClockIO+ioRhine = tagS @@ GlossEventClockIO >-- collect --> sim >-> arrMCl paintAllIO @@ GlossSimClockIO

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                rhine-gloss-version:             0.9+version:             1.0 synopsis:            Gloss backend for Rhine description:   This package provides a simple wrapper for the `gloss` library,@@ -26,7 +26,7 @@ source-repository this   type:     git   location: https://github.com/turion/rhine.git-  tag:      v0.9+  tag:      v1.0   library@@ -38,10 +38,11 @@     FRP.Rhine.Gloss.Pure.Combined   build-depends:       base         >= 4.14 && < 4.18                      , transformers >= 0.5-                     , rhine        == 0.9+                     , rhine        == 1.0                      , dunai        ^>= 0.9                      , gloss        >= 1.12                      , mmorph       >= 1.1+                     , monad-schedule >= 0.1   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions:

@@ -14,9 +14,11 @@   paintAllIO,   GlossEventClockIO (..),   GlossSimClockIO (..),+  launchInGlossThread,   launchGlossThread,   flowGlossIO,-  glossConcurrently,+  runGlossEnvClock,+  RunGlossEnvClock, ) where @@ -35,6 +37,9 @@ -- gloss import Graphics.Gloss.Interface.IO.Game +-- monad-schedule+import Control.Monad.Schedule.Class+ -- rhine import FRP.Rhine @@ -55,6 +60,9 @@   {unGlossConcT :: ReaderT GlossEnv m a}   deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MFunctor, MMonad) +instance (Monad m, MonadSchedule m) => MonadSchedule (GlossConcT m) where+  schedule actions = GlossConcT $ fmap (second $ map GlossConcT) $ schedule $ unGlossConcT <$> actions+ withPicRef ::   MonadIO m =>   (IORef Picture -> IO a) ->@@ -121,9 +129,8 @@ launchGlossThread ::   MonadIO m =>   GlossSettings ->-  GlossConcT m a ->-  m a-launchGlossThread GlossSettings {..} glossLoop = do+  m GlossEnv+launchGlossThread GlossSettings {..} = do   vars <- liftIO $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> pure 0   let     getPic GlossEnv {picRef} = readIORef picRef@@ -136,6 +143,24 @@       void $ tryPutMVar timeVar time'       return vars {time = time'}   void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep+  return vars++{- | Apply this to supply the 'GlossConcT' effect.+   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.+-}+launchInGlossThread ::+  MonadIO m =>+  GlossSettings ->+  GlossConcT m a ->+  m a+launchInGlossThread settings glossLoop = do+  vars <- launchGlossThread settings   runReaderT (unGlossConcT glossLoop) vars  {- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,@@ -151,37 +176,23 @@   GlossSettings ->   Rhine (GlossConcT m) cl () () ->   m ()-flowGlossIO settings = launchGlossThread settings . flow+flowGlossIO settings = launchInGlossThread settings . flow -{- | A schedule in the 'GlossConcT' transformer,-   supplying the same backend connection to its scheduled clocks.+{- | 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. -}-glossConcurrently ::-  ( Clock (GlossConcT IO) cl1-  , Clock (GlossConcT IO) cl2-  , Time cl1 ~ Time cl2-  ) =>-  Schedule (GlossConcT IO) cl1 cl2-glossConcurrently = Schedule $-  \cl1 cl2 -> GlossConcT $-    ReaderT $-      \vars ->-        first liftTransS-          <$> initSchedule-            concurrently-            (runGlossEnvClock vars cl1)-            (runGlossEnvClock vars cl2)--type RunGlossEnvClock cl = HoistClock (GlossConcT IO) IO cl+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'.+-} runGlossEnvClock ::   GlossEnv ->   cl ->-  RunGlossEnvClock cl+  RunGlossEnvClock m cl runGlossEnvClock env unhoistedClock =   HoistClock     { monadMorphism = flip runReaderT env . unGlossConcT     , ..     }---- FIXME And a schedule for gloss clocks and other clocks

@@ -1,4 +1,3 @@-{-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -19,39 +18,47 @@   GlossClSF,   currentEvent,   flowGloss,-  flowGlossWithWorldMSF,+  flowGlossClSF, ) where  -- base import qualified Control.Category as Category+import Data.Functor.Identity  -- transformers import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer+import Control.Monad.Trans.Writer.Strict  -- dunai+import Control.Monad.Trans.MSF (performOnFirstSample) import qualified Control.Monad.Trans.MSF.Reader as MSFReader+import qualified Control.Monad.Trans.MSF.Writer as MSFWriter import Data.MonadicStreamFunction.InternalCore +-- monad-schedule+import Control.Monad.Schedule.Class+import Control.Monad.Schedule.Yield+ -- rhine import FRP.Rhine-import FRP.Rhine.Reactimation.ClockErasure  -- rhine-gloss import FRP.Rhine.Gloss.Common  -- * @gloss@ effects --- FIXME How about a Reader (MSF () (Either Float Event))? That might unify the two backends and make the pure one more flexible.- -- | A pure monad in which all effects caused by the @gloss@ backend take place.-newtype GlossM a = GlossM {unGlossM :: (ReaderT (Float, Maybe Event)) (Writer Picture) a}+newtype GlossM a = GlossM {unGlossM :: YieldT (ReaderT (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+ -- | Add a picture to the canvas. paint :: Picture -> GlossM ()-paint = GlossM . lift . tell+paint = GlossM . lift . lift . tell  -- FIXME This doesn't what you think it does @@ -76,7 +83,7 @@ instance Clock GlossM GlossClock where   type Time GlossClock = Float   type Tag GlossClock = Maybe Event-  initClock _ = return (constM (GlossM ask) >>> (sumS *** Category.id), 0)+  initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id), 0)  instance GetClockProxy GlossClock @@ -99,29 +106,29 @@  -- * Reactimation -{- | The main function that will start the @gloss@ backend and run the 'SN'-   (in the case of the combined clock).--}-flowGloss ::+-- | Specialisation of 'flowGloss' to a 'GlossClSF'+flowGlossClSF ::   GlossSettings ->-  -- | The @gloss@-compatible 'Rhine'.+  -- | The @gloss@-compatible 'ClSF'.   GlossClSF ->   IO ()-flowGloss settings clsf = flowGlossWithWorldMSF settings GlossClock $ proc (time, tag) -> do-  arrM (const clear) -< ()-  pic <- eraseClockClSF getClockProxy 0 clsf -< (time, tag, ())-  arrM paint -< pic+flowGlossClSF settings clsf = flowGloss settings $ clsf >-> arrMCl paintAll @@ GlossClock --- FIXME Hide?+type WorldMSF = MSF Identity ((Float, Maybe Event), ()) (Picture, Maybe ()) --- | Helper function-flowGlossWithWorldMSF GlossSettings {..} clock msf =+-- | The main function that will start the @gloss@ backend and run the 'Rhine'+flowGloss ::+  (Clock GlossM cl, GetClockProxy cl) =>+  GlossSettings ->+  Rhine GlossM cl () () ->+  IO ()+flowGloss GlossSettings {..} rhine =   play display backgroundColor stepsPerSecond (worldMSF, Blank) getPic handleEvent simStep   where-    worldMSF = MSFReader.runReaderS $ morphS unGlossM $ proc () -> do-      (time, tag) <- fst $ fst $ runWriter $ flip runReaderT (0, Nothing) $ unGlossM $ initClock clock -< ()-      msf -< (time, tag)+    worldMSF :: WorldMSF+    worldMSF = MSFWriter.runWriterS $ MSFReader.runReaderS $ morphS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine+    stepWith :: (Float, Maybe Event) -> (WorldMSF, Picture) -> (WorldMSF, Picture)+    stepWith (diff, eventMaybe) (msf, _) = let ((picture, _), msf') = runIdentity $ unMSF msf ((diff, eventMaybe), ()) in (msf', picture)     getPic (_, pic) = pic-    stepWith (diff, maybeEvent) (msf, _) = first snd $ runWriter $ unMSF msf ((diff, maybeEvent), ())     handleEvent event = stepWith (0, Just event)     simStep diff = stepWith (diff, Nothing)

@@ -1,4 +1,3 @@-{-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-}  {- | A pure @gloss@ backend for Rhine,@@ -12,7 +11,6 @@  -- rhine import FRP.Rhine-import FRP.Rhine.Reactimation.ClockErasure  -- rhine-gloss import FRP.Rhine.Gloss.Common@@ -24,14 +22,9 @@ -} type GlossCombinedClock a =   SequentialClock-    GlossM     (GlossEventClock a)     GlossSimulationClock --- | Schedule the subclocks of the 'GlossCombinedClock'.-glossSchedule :: Schedule GlossM (GlossEventClock a) GlossSimulationClock-glossSchedule = schedSelectClocks- -- ** Events  -- | The clock that ticks whenever a specific @gloss@ event occurs.@@ -92,7 +85,7 @@  myGlossRhine :: GlossRhine a myGlossRhine-  = myEventSubsystem @@ myEventClock >-- collect -@- glossSchedule --> mySim @@ glossSimulationClock+  = myEventSubsystem @@ myEventClock >-- collect --> mySim @@ glossSimulationClock @ -} type GlossRhine a = Rhine GlossM (GlossCombinedClock a) () ()@@ -110,19 +103,5 @@   GlossRhine a buildGlossRhine selector clsfSim =   timeInfoOf tag @@ glossEventSelectClock selector-    >-- collect -@- glossSchedule+    >-- collect     --> clsfSim @@ glossSimulationClock---- * Reactimation---- | The main function that will start the @gloss@ backend and run the 'SN'.-flowGlossCombined ::-  GlossSettings ->-  -- | The @gloss@-compatible 'Rhine'.-  GlossRhine a ->-  IO ()-flowGlossCombined settings Rhine {..} = flowGlossWithWorldMSF settings clock $ proc tick -> do-  eraseClockSN 0 sn-    -< case tick of-      (_, Left event) -> (0, Left event, Just ())-      (diffTime, Right ()) -> (diffTime, Right (), Nothing)