essence-of-live-coding-gloss 0.2.6 → 0.2.7
raw patch · 5 files changed
+90/−79 lines, 5 filesdep ~essence-of-live-codingsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: essence-of-live-coding
API changes (from Hackage documentation)
Files
- Setup.hs +1/−0
- essence-of-live-coding-gloss.cabal +5/−5
- src/LiveCoding/Gloss.hs +69/−59
- src/LiveCoding/Gloss/Debugger.hs +7/−7
- src/LiveCoding/Gloss/PictureM.hs +8/−8
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
essence-of-live-coding-gloss.cabal view
@@ -1,5 +1,5 @@ name: essence-of-live-coding-gloss-version: 0.2.6+version: 0.2.7 synopsis: General purpose live coding framework - Gloss backend description: essence-of-live-coding is a general purpose and type safe live coding framework.@@ -27,12 +27,12 @@ source-repository head type: git- location: git@github.com:turion/essence-of-live-coding.git+ location: https://github.com/turion/essence-of-live-coding.git source-repository this type: git- location: git@github.com:turion/essence-of-live-coding.git- tag: v0.2.6+ location: https://github.com/turion/essence-of-live-coding.git+ tag: v0.2.7 library exposed-modules:@@ -43,7 +43,7 @@ base >= 4.11 && < 5 , syb >= 0.7 , transformers >= 0.5- , essence-of-live-coding >= 0.2.6+ , essence-of-live-coding >= 0.2.7 , foreign-store >= 0.2 , gloss >= 1.13 hs-source-dirs: src
src/LiveCoding/Gloss.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Arrows #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -module LiveCoding.Gloss- ( module X- , module LiveCoding.Gloss- ) where+module LiveCoding.Gloss (+ module X,+ module LiveCoding.Gloss,+) where -- base import Control.Concurrent@@ -15,8 +15,8 @@ -- transformers import Control.Arrow (returnA)-import Control.Monad.Trans.Writer import Control.Monad.Trans.State.Strict (StateT)+import Control.Monad.Trans.Writer -- gloss import Graphics.Gloss as X@@ -29,69 +29,79 @@ import LiveCoding.Gloss.Debugger as X import LiveCoding.Gloss.PictureM as X --- | In a 'Handle', store a separate thread where the gloss main loop is executed,--- and several concurrent variables to communicate with it.+{- | In a 'Handle', store a separate thread where the gloss main loop is executed,+ and several concurrent variables to communicate with it.+-} data GlossHandle = GlossHandle { glossThread :: ThreadId- , glossVars :: GlossVars+ , glossVars :: GlossVars } -- | The concurrent variables needed to communicate with the gloss thread. data GlossVars = GlossVars { glossEventsRef :: IORef [Event]- -- ^ Stores all 'Event's that arrived since the last tick- , glossPicRef :: IORef Picture- -- ^ Stores the next 'Picture' to be painted- , glossDTimeVar :: MVar Float- -- ^ Stores the time passed since the last tick- , glossExitRef :: IORef Bool- -- ^ Write 'True' here to stop the gloss thread+ -- ^ Stores all 'Event's that arrived since the last tick+ , glossPicRef :: IORef Picture+ -- ^ Stores the next 'Picture' to be painted+ , glossDTimeVar :: MVar Float+ -- ^ Stores the time passed since the last tick+ , glossExitRef :: IORef Bool+ -- ^ Write 'True' here to stop the gloss thread } --- | Collect all settings that the @gloss@ backend requires.--- Taken from @rhine-gloss@.+{- | Collect all settings that the @gloss@ backend requires.+ Taken from @rhine-gloss@.+-} data GlossSettings = GlossSettings- { displaySetting :: Display -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').- , backgroundColor :: Color -- ^ Background color.- , stepsPerSecond :: Int -- ^ Number of simulation steps per second of real time.- , debugEvents :: Bool -- ^ Print all incoming events to the console.+ { displaySetting :: Display+ -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').+ , backgroundColor :: Color+ -- ^ Background color.+ , stepsPerSecond :: Int+ -- ^ Number of simulation steps per second of real time.+ , debugEvents :: Bool+ -- ^ Print all incoming events to the console. } defaultSettings :: GlossSettings-defaultSettings = GlossSettings- { displaySetting = InWindow "Essence of live coding" (600, 800) (20, 20)- , backgroundColor = black- , stepsPerSecond = 30- , debugEvents = False- }+defaultSettings =+ GlossSettings+ { displaySetting = InWindow "Essence of live coding" (600, 800) (20, 20)+ , backgroundColor = black+ , stepsPerSecond = 30+ , debugEvents = False+ } --- | Will create a handle for communication with the gloss thread,--- and start gloss.+{- | Will create a handle for communication with the gloss thread,+ and start gloss.+-} glossHandle :: GlossSettings -> Handle IO GlossHandle-glossHandle GlossSettings { .. } = Handle- { create = do- glossEventsRef <- newIORef []- glossDTimeVar <- newEmptyMVar- glossPicRef <- newIORef blank- glossExitRef <- newIORef False- let glossVars = GlossVars { .. }- glossThread <- forkIO- $ playIO displaySetting backgroundColor stepsPerSecond glossVars getPicture (handleEvent debugEvents) stepGloss- return GlossHandle { .. }- , destroy = \GlossHandle { glossVars = GlossVars { .. }, .. } -> writeIORef glossExitRef True- }+glossHandle GlossSettings {..} =+ Handle+ { create = do+ glossEventsRef <- newIORef []+ glossDTimeVar <- newEmptyMVar+ glossPicRef <- newIORef blank+ glossExitRef <- newIORef False+ let glossVars = GlossVars {..}+ glossThread <-+ forkIO $+ playIO displaySetting backgroundColor stepsPerSecond glossVars getPicture (handleEvent debugEvents) stepGloss+ return GlossHandle {..}+ , destroy = \GlossHandle {glossVars = GlossVars {..}, ..} -> writeIORef glossExitRef True+ } getPicture :: GlossVars -> IO Picture-getPicture GlossVars { .. } = readIORef glossPicRef+getPicture GlossVars {..} = readIORef glossPicRef handleEvent :: Bool -> Event -> GlossVars -> IO GlossVars-handleEvent debugEvents event vars@GlossVars { .. } = do+handleEvent debugEvents event vars@GlossVars {..} = do when debugEvents $ print event modifyIORef glossEventsRef (event :) return vars stepGloss :: Float -> GlossVars -> IO GlossVars-stepGloss dTime vars@GlossVars { .. } = do+stepGloss dTime vars@GlossVars {..} = do putMVar glossDTimeVar dTime exitNow <- readIORef glossExitRef when exitNow exitSuccess@@ -107,22 +117,22 @@ The resulting cell never blocks, but returns 'Nothing' if there currently is no gloss tick. -}-glossWrapC- :: GlossSettings- -> Cell PictureM a b- -> Cell (HandlingStateT IO) a (Maybe b)+glossWrapC ::+ GlossSettings ->+ Cell PictureM a b ->+ Cell (HandlingStateT IO) a (Maybe b) glossWrapC glossSettings cell = proc a -> do- GlossHandle { .. } <- handling $ glossHandle glossSettings -< ()+ GlossHandle {..} <- handling $ glossHandle glossSettings -< () liftCell pump -< (glossVars, a) where- pump = proc (GlossVars { .. }, a) -> do- timeMaybe <- arrM tryTakeMVar -< glossDTimeVar+ pump = proc (GlossVars {..}, a) -> do+ timeMaybe <- arrM tryTakeMVar -< glossDTimeVar case timeMaybe of Just _ -> do- events <- arrM $ flip atomicModifyIORef ([], ) -< glossEventsRef- (picture, b) <- runPictureT cell -< (events, a)- arrM (uncurry writeIORef) -< (glossPicRef, picture)- returnA -< Just b+ events <- arrM $ flip atomicModifyIORef ([],) -< glossEventsRef+ (picture, b) <- runPictureT cell -< (events, a)+ arrM (uncurry writeIORef) -< (glossPicRef, picture)+ returnA -< Just b Nothing -> do- arrM threadDelay -< 1000 -- Prevent too much CPU load- returnA -< Nothing+ arrM threadDelay -< 1000 -- Prevent too much CPU load+ returnA -< Nothing
src/LiveCoding/Gloss/Debugger.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Arrows #-}+ module LiveCoding.Gloss.Debugger where -- base@@ -6,9 +7,9 @@ import Data.Data -- transformers-import Control.Monad.Trans.Writer.Strict import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.Strict -- syb import Data.Generics.Text@@ -32,9 +33,8 @@ every maxN = proc () -> do n <- sumC -< 1 if n `mod` maxN == 0- then do- s <- getC -< ()- let pic = statePicture s- returnA -< Just pic- else- returnA -< Nothing+ then do+ s <- getC -< ()+ let pic = statePicture s+ returnA -< Just pic+ else returnA -< Nothing
src/LiveCoding/Gloss/PictureM.hs view
@@ -1,7 +1,7 @@-module LiveCoding.Gloss.PictureM- ( module LiveCoding.Gloss.PictureM- , module X- ) where+module LiveCoding.Gloss.PictureM (+ module LiveCoding.Gloss.PictureM,+ module X,+) where -- transformers import Control.Monad.Trans.Class@@ -29,10 +29,10 @@ type PictureM = PictureT IO -- | Run the effects of the gloss monad stack by explicitly passing events and pictures.-runPictureT- :: Monad m- => Cell (PictureT m) a b- -> Cell m ([Event], a) (Picture, b)+runPictureT ::+ Monad m =>+ Cell (PictureT m) a b ->+ Cell m ([Event], a) (Picture, b) runPictureT = runWriterC . runReaderC' addPicture :: Monad m => Cell (PictureT m) Picture ()