diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/essence-of-live-coding-gloss.cabal b/essence-of-live-coding-gloss.cabal --- a/essence-of-live-coding-gloss.cabal +++ b/essence-of-live-coding-gloss.cabal @@ -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 diff --git a/src/LiveCoding/Gloss.hs b/src/LiveCoding/Gloss.hs --- a/src/LiveCoding/Gloss.hs +++ b/src/LiveCoding/Gloss.hs @@ -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 diff --git a/src/LiveCoding/Gloss/Debugger.hs b/src/LiveCoding/Gloss/Debugger.hs --- a/src/LiveCoding/Gloss/Debugger.hs +++ b/src/LiveCoding/Gloss/Debugger.hs @@ -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 diff --git a/src/LiveCoding/Gloss/PictureM.hs b/src/LiveCoding/Gloss/PictureM.hs --- a/src/LiveCoding/Gloss/PictureM.hs +++ b/src/LiveCoding/Gloss/PictureM.hs @@ -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 ()