rhine-gloss 1.3 → 1.4

raw patch · 6 files changed

+133/−36 lines, 6 filesdep ~rhinePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: rhine

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• rhine-gloss.cabal +3/−3
• src/FRP/Rhine/Gloss.hs +1/−1
• src/FRP/Rhine/Gloss/IO.hs +122/−30
• src/FRP/Rhine/Gloss/Pure.hs +0/−1
• src/FRP/Rhine/Gloss/Pure/Combined.hs +1/−1

@@ -1,5 +1,11 @@ # Revision history for rhine-gloss +## 1.4++* Use `FreeAsyncT` in the gloss IO backend for fairer concurrency.+  See https://hackage.haskell.org/package/monad-schedule-0.2/docs/Control-Monad-Schedule-FreeAsync.html.+* Improvements, utilities, and hardenings for the IO backend+ ## 1.3  * Dropped `dunai` dependency in favour of state automata.

@@ -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.3+version: 1.4 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: v1.3+  tag: v1.4  library   exposed-modules:@@ -42,7 +42,7 @@     gloss >=1.12,     mmorph >=1.1,     monad-schedule >=0.1,-    rhine ==1.3,+    rhine ==1.4,     transformers >=0.5    hs-source-dirs: src

@@ -3,7 +3,7 @@ A pure Rhine app with @gloss@ backend must use the 'GlossClock' or 'GlossCombinedClock' (from 'FRP.Rhine.Gloss.Pure.Single' and 'FRP.Rhine.Gloss.Pure.Combined', respectively), since the @gloss@ API only offers callbacks.-In order to run such a reactive program, you have to use 'flowGloss' or 'flowGlossCombined'.+In order to run such a reactive program, you have to use 'flowGloss'.  A more flexible alternative, at the cost of introducing 'IO' concurrency, is the 'FRP.Rhine.Gloss.IO' wrapper.

@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}@@ -8,47 +10,57 @@  -- | Wrapper to write @gloss@ applications in Rhine, using concurrency. module FRP.Rhine.Gloss.IO (-  GlossConcT,+  GlossEnv (..),+  GlossConcT (..),+  GlossConc,+  runGlossConcT,   paintIO,   clearIO,   paintAllIO,   GlossEventClockIO (..),   GlossSimClockIO (..),+  makeGlossEnv,   launchInGlossThread,   launchGlossThread,   flowGlossIO,   runGlossEnvClock,   RunGlossEnvClock,+  GlossClockUTC,+  glossClockUTC,+  GlossConcTClock,+  glossConcTClock,+  GlossConcClock,+  glossConcClock, ) where  -- base import Control.Concurrent-import Control.Monad (when) import Data.Functor (void) import Data.IORef+import System.Timeout (timeout)  -- transformers import Control.Monad.Trans.Class import Control.Monad.Trans.Reader --- mmorph-import Control.Monad.Morph- -- gloss import Graphics.Gloss.Interface.IO.Game  -- monad-schedule import Control.Monad.Schedule.Class+import Control.Monad.Schedule.FreeAsync  -- rhine import FRP.Rhine+import FRP.Rhine.Clock.Realtime (UTCClock, addUTC)  -- rhine-gloss import FRP.Rhine.Gloss.Common  -- * Gloss effects +-- | Concurrent variables needed to communicate with the gloss backend. data GlossEnv = GlossEnv   { timeVar :: MVar Float   , eventVar :: MVar Event@@ -56,12 +68,29 @@   , timeRef :: IORef Float   } --- | Wraps the concurrent variables needed for communication with 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+-} newtype GlossConcT m a = GlossConcT-  {unGlossConcT :: ReaderT GlossEnv m a}-  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MFunctor, MMonad)+  {unGlossConcT :: ReaderT GlossEnv (FreeAsyncT m) a}+  deriving (Functor, Applicative, Monad, MonadIO) -instance (Monad m, MonadSchedule m) => MonadSchedule (GlossConcT m) where+-- | 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++-- 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++-- | 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  withPicRef ::@@ -82,11 +111,16 @@  -- | Clear the canvas and then paint. paintAllIO :: (MonadIO m) => Picture -> GlossConcT m ()-paintAllIO pic = clearIO >> paintIO pic+paintAllIO pic = withPicRef $ \ref -> writeIORef ref pic  -- * Gloss clocks in 'IO' --- | Concurrently block on @gloss@ events.+{- | Concurrently block on @gloss@ events.++Caution: Currently, you should only add one such clock in a 'Rhine'.+If you add several 'GlossEventClockIO', only one will be chosen at random and receive the event.+See https://github.com/turion/rhine/issues/330.+-} data GlossEventClockIO = GlossEventClockIO  instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where@@ -96,14 +130,19 @@     where       getEvent = do         GlossEnv {eventVar, timeRef} <- GlossConcT ask+        event <- GlossConcT $ lift $ asyncMVar eventVar         liftIO $ do-          event <- takeMVar eventVar           time <- readIORef timeRef           return (time, event)  instance GetClockProxy GlossEventClockIO --- | Concurrently block on @gloss@ simulation ticks.+{- | Concurrently block on @gloss@ simulation ticks.++Caution: Currently, you should only add one such clock in a 'Rhine'.+If you add several 'GlossSimClockIO', only one will be chosen at random and receive the event.+See https://github.com/turion/rhine/issues/330.+-} data GlossSimClockIO = GlossSimClockIO  instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where@@ -111,40 +150,49 @@   type Tag GlossSimClockIO = ()   initClock _ = return (constM getTime &&& arr (const ()), 0)     where-      getTime = do-        GlossEnv {timeVar} <- GlossConcT ask-        liftIO $ takeMVar timeVar+      getTime = GlossConcT $ do+        GlossEnv {timeVar} <- ask+        lift $ asyncMVar timeVar  instance GetClockProxy GlossSimClockIO  -- * Reactimation -{- | Apply this to supply the 'GlossConcT' effect.-   Creates a new thread in which @gloss@ is run,-   and feeds the clocks 'GlossEventClockIO' and 'GlossSimClockIO'.+{- | Create the concurrent variables to communicate with the @gloss@ backend. -   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.+You will usually not need this function, have a look at 'launchInGlossThread' and 'flowGlossIO' instead. -}+makeGlossEnv ::+  (MonadIO m) =>+  m GlossEnv+makeGlossEnv = liftIO $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> newIORef 0++{- | Helper function for 'launchInGlossThread'.++Creates concurrent variables and launches the @gloss@ backend in a separate thread.+-} launchGlossThread ::   (MonadIO m) =>   GlossSettings ->   m GlossEnv launchGlossThread GlossSettings {..} = do-  vars <- liftIO $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> newIORef 0+  vars <- makeGlossEnv   let     getPic GlossEnv {picRef} = readIORef picRef-    -- Only try to put so this doesn't hang in case noone is listening for events or ticks     handleEvent event vars@GlossEnv {eventVar} = do-      void $ tryPutMVar eventVar event+      void $+        forkIO $ -- Perform non-blocking so other actions are not delayed+          void $+            timeout 100000 $ -- timeout in case noone is listening for events+              putMVar eventVar event       return vars     simStep diffTime vars@GlossEnv {timeVar, timeRef} = do       time <- readIORef timeRef       let !time' = time + diffTime-      timeUpdate <- tryPutMVar timeVar time'-      when timeUpdate $ writeIORef timeRef time'+      -- We don't do this in a separate thread, because forkIO putMVar would create a race condition on putting the MVar,+      -- which can lead to non-monotonous time updates.+      tryPutMVar timeVar time'+      writeIORef timeRef time'       return vars   void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep   return vars@@ -165,7 +213,7 @@   m a launchInGlossThread settings glossLoop = do   vars <- launchGlossThread settings-  runReaderT (unGlossConcT glossLoop) vars+  runGlossConcT glossLoop vars  {- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,    and reactimate in the foreground.@@ -192,11 +240,55 @@   You will have to have initialized a 'GlossEnv', for example by calling 'launchGlossThread'. -} runGlossEnvClock ::+  (MonadIO m) =>   GlossEnv ->   cl ->   RunGlossEnvClock m cl runGlossEnvClock env unhoistedClock =   HoistClock-    { monadMorphism = flip runReaderT env . unGlossConcT+    { monadMorphism = flip runGlossConcT env     , ..     }++-- * Lifting clocks to 'GlossConcT'++{- | Lift a 'MonadIO' clock to 'GlossConcT'.++You should use this instead of 'IOClock', otherwise scheduling will probably not work.+(This is because 'GlossConcT' uses 'FreeAsyncT', but 'liftIO' is not asynchronous.)+-}+type GlossConcTClock m = HoistClock IO (GlossConcT m)++-- | A 'MonadIO' clock lifted to 'GlossConcT'.+glossConcTClock :: (MonadIO m) => cl -> GlossConcTClock m cl+glossConcTClock unhoistedClock =+  HoistClock+    { unhoistedClock+    , monadMorphism = GlossConcT . lift . freeAsync+    }++{- | Lift an 'IO' clock to 'GlossConc'.++See 'GlossConcTClock'.+-}+type GlossConcClock = GlossConcTClock IO++-- | An 'IO' clock lifted to 'GlossConc'.+glossConcClock :: cl -> GlossConcClock cl+glossConcClock = glossConcTClock++-- * Rescaled clocks in other time domains++{- | Rescale a gloss clock like 'GlossSimClockIO' or 'GlossEventClockIO' to 'UTCTime'.++This is needed for compatibility with other realtime clocks like 'Millisecond'.+-}+type GlossClockUTC m cl = UTCClock (GlossConcT m) cl++{- | Rescale a gloss clock like 'GlossSimClockIO' or 'GlossEventClockIO' to 'UTCTime'.++Uses 'addUTC'. For other strategies to rescale a gloss clock to 'UTCTime',+see "FRP.Rhine.Clock.Realtime".+-}+glossClockUTC :: (MonadIO m, Real (Time cl)) => cl -> GlossClockUTC m cl+glossClockUTC = addUTC

@@ -38,7 +38,6 @@ import Data.Automaton.Trans.Except (performOnFirstSample) import qualified Data.Automaton.Trans.Reader as AutomatonReader import qualified Data.Automaton.Trans.Writer as AutomatonWriter-import Data.Stream.Result (Result (..))  -- rhine import FRP.Rhine

@@ -4,7 +4,7 @@ with separated event and simulation loop.  To run pure Rhine apps with @gloss@,-write a signal network ('SN') in the 'GlossCombinedClock' and use 'flowGlossCombined'.+write a signal network ('SN') in the 'GlossCombinedClock' and use 'flowGloss'. As an easy starter, you can use the helper function 'buildGlossRhine'. -} module FRP.Rhine.Gloss.Pure.Combined where