From acc954c9ac3a18e2d48e52839a7dc751597dfb15 Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Wed, 1 Jan 2025 11:39:25 -0800 Subject: Streamling the Game monad, use MonadIO for automatic lifting. --- Demos/Pong/Main.hs | 62 ++++++++++--------- Spear/App.hs | 135 +++++++++++++++++++++++++++++++----------- Spear/Game.hs | 84 +++++++++++++------------- Spear/Render/Core/Buffer.hs | 5 +- Spear/Render/Core/Geometry.hs | 9 +-- Spear/Render/Core/Pipeline.hs | 24 ++++---- Spear/Render/Core/Shader.hs | 15 ++--- Spear/Render/Immediate.hs | 17 +++--- Spear/Scene/Loader.hs | 2 +- Spear/Sound/Sound.hs | 13 ++-- Spear/Sys/Timer.hsc | 21 +++---- Spear/Window.hs | 36 +++++------ 12 files changed, 246 insertions(+), 177 deletions(-) diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index f77136f..eafa983 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Main where import Pong @@ -21,15 +23,16 @@ import Control.Monad (when) import Data.Maybe (mapMaybe) -data GameState = GameState - { context :: AppContext - , renderCoreState :: RenderCoreState - , immRenderState :: ImmRenderState +data Pong = Pong + { immRenderState :: ImmRenderState , viewProjection :: Matrix4 , backgroundMusic :: SoundSource , world :: [GameObject] } +type GameState = AppState Pong + + options = defaultAppOptions { title = "Pong" } app = App options initGame endGame step render resize @@ -38,32 +41,38 @@ app = App options initGame endGame step render resize main :: IO () main = runApp app -initGame :: AppContext -> Game () GameState -initGame context = do - (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState - (music, soundState') <- flip runSiblingGame (appSoundState context) $ do +initGame :: Game AppContext Pong +initGame = do + renderCoreState <- contextRenderCoreState <$> get + (immRenderState, renderCoreState') <- runSiblingGame renderCoreState newImmRenderer + -- TODO: This can work if we use FlexibleContexts and change the function signatures. + --immRenderState <- newImmRenderer + music <- siblingGame $ do musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav" music <- makeSoundSource - liftIO $ do - setSoundSourceBuffer music musicBuffer - setSoundLoopMode music Loop - playSounds [music] + -- TODO: setSoundSourceBuffer generates an AL error for some reason, though + -- the music still plays. + -- "user error (runALUT: There was already an AL error on entry to an ALUT function)" + setSoundSourceBuffer music musicBuffer + setSoundLoopMode music Loop + playSounds [music] return music - let context' = context { appSoundState = soundState' } - return $ GameState context' renderCoreState immRenderState Matrix4.id music newWorld + return $ Pong immRenderState Matrix4.id music newWorld endGame :: Game GameState () endGame = do - game <- get - runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game) + renderCoreState <- appRenderCoreState <$> get + game <- getGameState + exec' runSiblingGame renderCoreState (deleteImmRenderer $ immRenderState game) step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool step elapsed dt inputEvents = do - gameState <- get - events <- processInput (appWindow . context $ gameState) + appState <- get + gameState <- getGameState + events <- processInput (appWindow appState) --when (events /= []) $ liftIO . putStrLn $ show events - modify $ \gameState -> gameState + modifyGameState $ \pong -> pong { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState) } return (not $ exitRequested inputEvents) @@ -79,18 +88,17 @@ exitRequested = elem (KeyDown KEY_ESC) render :: Game GameState () render = do - gameState <- get - immRenderState' <- flip execSubGame (immRenderState gameState) $ do + gameState <- getGameState + immRenderState' <- exec runSiblingGame (immRenderState gameState) $ do immStart immSetViewProjectionMatrix (viewProjection gameState) -- Clear the background to a different colour than the playable area to make -- the latter distinguishable. - liftIO $ do - setClearColour (0.2, 0.2, 0.2, 0.0) - clearBuffers [ColourBuffer] + setClearColour (0.2, 0.2, 0.2, 0.0) + clearBuffers [ColourBuffer] render' $ world gameState immEnd - put $ gameState { immRenderState = immRenderState' } + putGameState $ gameState { immRenderState = immRenderState' } render' :: [GameObject] -> Game ImmRenderState () render' world = do @@ -132,7 +140,7 @@ resize (ResizeEvent w h) = bottom = if r > 1 then 0 else -pad top = if r > 1 then 1 else 1 + pad in do - liftIO $ setViewport 0 0 w h - modify $ \state -> state { + setViewport 0 0 w h + modifyGameState $ \pong -> pong { viewProjection = Matrix4.ortho left right bottom top (-1) 1 } diff --git a/Spear/App.hs b/Spear/App.hs index 8c0371e..75bf6fa 100644 --- a/Spear/App.hs +++ b/Spear/App.hs @@ -1,26 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Spear.App ( App(..) , AppOptions(..) , AppContext(..) +, AppState(..) , Elapsed , Dt , Step , defaultAppOptions +, getGameState +, putGameState +, modifyGameState , runApp , loop ) where import Spear.Game +import Spear.Render.Core.State import Spear.Sound.Sound import Spear.Sound.State -import Spear.Sys.Timer as Timer +import Spear.Sys.Timer as Timer import Spear.Window import Control.Monad -import Data.Fixed (mod') +import Data.Fixed (mod') import GHC.Float + -- | Time elapsed. type Elapsed = Double @@ -31,6 +39,8 @@ type Dt = Double type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool -- | Application options. +-- +-- Use `defaultOptions` for default options. data AppOptions = AppOptions { title :: String , windowWidth :: Int @@ -40,6 +50,7 @@ data AppOptions = AppOptions , enableProfiling :: Bool } +-- | Default application options. defaultAppOptions = AppOptions { title = "Spear Application" , windowWidth = 1920 @@ -49,55 +60,105 @@ defaultAppOptions = AppOptions , enableProfiling = False } --- | Application state. +-- | Application descriptor. data App s = App { appOptions :: AppOptions - , initApp :: AppContext -> Game () s - , endApp :: Game s () - , stepApp :: Step s - , renderApp :: Game s () - , resizeApp :: WindowEvent -> Game s () + , initApp :: Game AppContext s + , endApp :: Game (AppState s) () + , stepApp :: Step (AppState s) + , renderApp :: Game (AppState s) () + , resizeApp :: WindowEvent -> Game (AppState s) () } -- | Application context. +-- +-- The application context is the initial state from which the application's +-- `AppState` is bootstrapped with `initApp`. data AppContext = AppContext - { appWindow :: Window - , appSoundState :: SoundState + { contextWindow :: Window + , contextRenderCoreState :: RenderCoreState + , contextSoundState :: SoundState } +instance HasState AppContext RenderCoreState where + getInnerState = contextRenderCoreState + setInnerState context renderCoreState = context { contextRenderCoreState = renderCoreState } + +instance HasState AppContext SoundState where + getInnerState = contextSoundState + setInnerState context soundState = context { contextSoundState = soundState } + +-- | Application state. +data AppState s = AppState + { appWindow :: Window + , appRenderCoreState :: RenderCoreState + , appSoundState :: SoundState + , customState :: s + } + +instance HasState (AppState s) RenderCoreState where + getInnerState = appRenderCoreState + setInnerState appState renderCoreState = appState { appRenderCoreState = renderCoreState } + +instance HasState (AppState s) SoundState where + getInnerState = appSoundState + setInnerState appState soundState = appState { appSoundState = soundState } + + +-- | Get the custom state in the app state. +getGameState :: Game (AppState s) s +getGameState = customState <$> get + +-- | Put the custom state in the app state. +putGameState :: s -> Game (AppState s) () +putGameState custom = do + appState <- get + put $ appState { customState = custom } + +-- | Modify the custom state in the app state. +modifyGameState :: (s -> s) -> Game (AppState s) () +modifyGameState f = modify $ \appState -> appState { customState = f (customState appState )} + -- | Run the application. runApp :: App s -> IO () runApp app = let ops = appOptions app w = windowWidth ops h = windowHeight ops - in withWindow (w, h) (title ops) $ \window -> - withSoundContext $ flip evalGame () $ do - soundState <- evalSiblingGame initSoundSystem () - let appContext = AppContext window soundState - gameState <- initApp app appContext - (result, endGameState) <- runSubGame (loop app window) gameState - runSubGame' (endApp app) endGameState - runSiblingGame' destroySoundSystem soundState - --- | Convert FPS to desired delta time. -fpsToDdt :: Int -> TimeDelta -fpsToDdt fps = if fps > 0 then secToTimeDelta (1.0 / fromIntegral fps) else 0 + in -- Initialize subsystems. + withWindow (w, h) (title ops) $ \window -> + withSoundContext $ eval runGame () $ do + -- Create initial context. + initialSoundState <- eval runSiblingGame () initSoundSystem + let context = AppContext window newRenderCoreState initialSoundState + -- Create initial app state. + (gameState, context') <- runSiblingGame context (initApp app) + let appState = AppState { + appWindow = contextWindow context' + , appRenderCoreState = contextRenderCoreState context' + , appSoundState = contextSoundState context' + , customState = gameState + } + -- Run app. + (result, endGameState) <- runSiblingGame appState (loop app window) + -- Shut down. + exec' runSiblingGame endGameState (endApp app) + exec' runSiblingGame (appSoundState appState) destroySoundSystem -- | Enter the main application loop. -loop :: App s -> Window -> Game s () +loop :: App s -> Window -> Game (AppState s) () loop app window = do -- For convenience, trigger an initial resize followed by a render of the -- application's initial state. - (width, height) <- liftIO $ getWindowSize window + (width, height) <- getWindowSize window resizeApp app (ResizeEvent width height) renderApp app let ddt = fpsToDdt . maxFPS . appOptions $ app -- Desired render time step. let animationDdt = fpsToDdt . animationFPS . appOptions $ app -- Desired animation time step. - timer <- liftIO newTimer - liftIO $ Timer.start timer + timer <- newTimer + Timer.start timer let lastAnimationTime = lastTick timer loop' window ddt animationDdt lastAnimationTime timer app @@ -108,18 +169,18 @@ loop' :: TimePoint -> -- Time point of last animation update. Timer -> App s -> - Game s () + Game (AppState s) () loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do - timer <- liftIO $ tick inputTimer - windowEvents <- liftIO $ pollWindowEvents window - close <- liftIO $ shouldWindowClose window + timer <- tick inputTimer + windowEvents <- pollWindowEvents window + close <- shouldWindowClose window (continue, lastAnimationTimeNextFrame) <- case animationDdt of 0 -> do -- Variable time step game animation. let t = timeDeltaToSec $ runningTime timer let dt = timeDeltaToSec $ deltaTime timer - inputEvents <- liftIO $ pollInputEvents window + inputEvents <- pollInputEvents window continue <- stepApp app t dt inputEvents return (continue, lastAnimationTime) @@ -139,7 +200,7 @@ loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do let lastAnimationTimeNextFrame = timeAdd lastAnimationTime (steps * ddt) --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt continue <- and <$> forM [1..steps] (\i -> do - inputEvents <- liftIO $ pollInputEvents window + inputEvents <- pollInputEvents window let t = timeDeltaToSec $ elapsed + i * ddt stepApp app t dt inputEvents) return (continue, lastAnimationTimeNextFrame) @@ -151,16 +212,20 @@ loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do -- For smoother resizing, render only while not resizing. unless resized $ do renderApp app - liftIO $ swapBuffers window + swapBuffers window -- Limit frame rate if so requested by the application. -- This currently makes the rendering stutter and is not very desirable. when ((maxFPS . appOptions $ app) > 0) $ do - frameEnd <- liftIO now + frameEnd <- now let ddt = renderDdt let frameTime = timeDiff (lastTick timer) frameEnd when (frameTime < ddt) $ do - liftIO $ Timer.sleep (ddt - frameTime) + Timer.sleep (ddt - frameTime) when (continue && not close) $ do loop' window renderDdt animationDdt lastAnimationTimeNextFrame timer app + +-- | Convert FPS to desired delta time. +fpsToDdt :: Int -> TimeDelta +fpsToDdt fps = if fps > 0 then secToTimeDelta (1.0 / fromIntegral fps) else 0 diff --git a/Spear/Game.hs b/Spear/Game.hs index 92cc680..1af8e9b 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs @@ -1,8 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Spear.Game ( Game -, GameException (..) -, ResourceClass (..) +, GameException(..) +, HasState(..) +, ResourceClass(..) , ReleaseKey -- * Game state , get @@ -18,15 +21,12 @@ module Spear.Game , catch -- * Running and IO , runGame -, evalGame , runSubGame -, runSubGame' -, evalSubGame -, execSubGame , runSiblingGame -, runSiblingGame' -, evalSiblingGame -, execSiblingGame +, eval +, exec +, exec' +, siblingGame , liftIO ) where @@ -44,7 +44,6 @@ import Control.Monad.Trans.Resource class ResourceClass a where getResource :: a -> ReleaseKey - -- | A game exception. -- -- This is mostly a convenient wrapper around `String` so that we can throw @@ -53,7 +52,6 @@ newtype GameException = GameException String deriving (Show) instance Exception GameException - -- | The game monad. -- -- The game monad performs three different roles: @@ -73,6 +71,14 @@ newtype Game s a = Game { getGame :: StateT s (ResourceT IO) a } , MonadResource ) +-- | A class used to define state hierarchies. +-- +-- By declaring `HasState s t`, a `Game s` monad can then execute actions of a +-- `Game t` monad more conveniently with `siblingGame`. +class HasState s t where + getInnerState :: s -> t + setInnerState :: s -> t -> s + -- | Release the given 'Resource'. release' :: ResourceClass a => a -> Game s () @@ -91,49 +97,39 @@ assertMaybe (Just x) _ = return x -- result and its final state. -- -- Any resources acquired by the given game are released when this returns. -runGame :: Game s a -> s -> IO (a, s) -runGame game = runResourceT . runStateT (getGame game) - --- | Run the given game and return its result. -evalGame :: Game s a -> s -> IO a -evalGame g s = fst <$> runGame g s +runGame :: s -> Game s a -> IO (a, s) +runGame state game = runResourceT . runStateT (getGame game) $ state -- | Run the given sub-game, unrolling the full monad stack and returning the -- game's result and its final state. -- -- Like `runGame`, this frees any resources that are acquired by the sub-game. -- If you want to keep acquired resources, see `runSiblingGame` instead. -runSubGame :: Game s a -> s -> Game t (a, s) -runSubGame g s = liftIO $ runGame g s - --- | Run the given sub-game and return its result. -evalSubGame :: Game s a -> s -> Game t a -evalSubGame g s = fst <$> runSubGame g s - --- | Like 'runSubGame', but discarding the result. -runSubGame' :: Game s a -> s -> Game t () -runSubGame' g s = void $ runSubGame g s - --- | Run the given sub-game and return its state. -execSubGame :: Game s a -> s -> Game t s -execSubGame g s = snd <$> runSubGame g s +runSubGame :: s -> Game s a -> Game t (a, s) +runSubGame state game = liftIO $ runGame state game -- | Run the given sibling game, unrolling the state transformer but not the -- resource transformer. -- -- Unlike `runSubGame`, any resources acquired by the sibling game are *not* -- released. -runSiblingGame :: Game s a -> s -> Game t (a, s) -runSiblingGame game = Game . lift . runStateT (getGame game) +runSiblingGame :: s -> Game s a -> Game t (a, s) +runSiblingGame state game = Game . lift $ runStateT (getGame game) state --- | Like 'runSiblingGame', but discarding the result. -runSiblingGame' :: Game s a -> s -> Game t () -runSiblingGame' g s = void $ runSiblingGame g s - --- | Run the given sibling game and return its result. -evalSiblingGame :: Game s a -> s -> Game t a -evalSiblingGame g s = fst <$> runSiblingGame g s - --- | Run the given sibling game and return its state. -execSiblingGame :: Game s a -> s -> Game t s -execSiblingGame g s = snd <$> runSiblingGame g s +-- | Run the given game and return its result. +--eval :: (Monad m s, Monad n s) => (m s a -> s -> n (a, s)) -> m s a -> s -> m a +eval runner game state = fst <$> runner game state + +-- | Run the given game and return its final state. +exec runner game state = snd <$> runner game state + +-- | Run the given game and ignore both its result and final state. +exec' runner game state = void $ runner game state + +-- | Run a sibling game on nested state. +siblingGame :: HasState s t => Game t a -> Game s a +siblingGame tAction = do + tState <- getInnerState <$> get + (result, tState') <- runSiblingGame tState tAction + modify $ \outerState -> setInnerState outerState tState' + return result diff --git a/Spear/Render/Core/Buffer.hs b/Spear/Render/Core/Buffer.hs index eaff475..3003987 100644 --- a/Spear/Render/Core/Buffer.hs +++ b/Spear/Render/Core/Buffer.hs @@ -14,6 +14,7 @@ import Spear.Math.Vector import Spear.Render.Core.State import Control.Monad (unless, void) +import Control.Monad.IO.Class import qualified Data.HashMap as HashMap import Data.Word import Foreign.C.Types @@ -68,8 +69,8 @@ deleteBuffer buffer = do release' buffer -- TODO: use glBufferSubData for updates. -updateBuffer :: Buffer -> BufferData -> IO () -updateBuffer buffer bufferData = +updateBuffer :: MonadIO io => Buffer -> BufferData -> io () +updateBuffer buffer bufferData = liftIO $ unless (bufferEmpty bufferData) $ do glBindBuffer GL_ARRAY_BUFFER (bufferHandle buffer) uploadData (bufferUsage buffer) bufferData diff --git a/Spear/Render/Core/Geometry.hs b/Spear/Render/Core/Geometry.hs index 10ff709..05c23ec 100644 --- a/Spear/Render/Core/Geometry.hs +++ b/Spear/Render/Core/Geometry.hs @@ -21,6 +21,7 @@ import Spear.Render.Core.Buffer import Spear.Render.Core.Constants import Spear.Render.Core.State +import Control.Monad.IO.Class import Data.HashMap as HashMap import Data.IORef import Data.Maybe (fromJust) @@ -105,8 +106,8 @@ deleteGeometry geometry = do geometries = HashMap.delete (geometryVao geometry) (geometries state) }) release' geometry -renderGeometry :: Geometry -> IO () -renderGeometry geometry = do +renderGeometry :: MonadIO io => Geometry -> io () +renderGeometry geometry = liftIO $ do gdata <- readIORef (geometryData geometry) let mode = toGLPrimitiveType $ geometryPrimitiveType gdata glBindVertexArray (geometryVao geometry) @@ -121,8 +122,8 @@ renderGeometry geometry = do -- Functions for updating dynamic geometry. -setPositions :: Geometry -> [Vector3] -> IO () -setPositions geometry vectors = do +setPositions :: MonadIO io => Geometry -> [Vector3] -> io () +setPositions geometry vectors = liftIO $ do gdata <- readIORef $ geometryData geometry case vertexPositions gdata of VertexPositions3d view -> do diff --git a/Spear/Render/Core/Pipeline.hs b/Spear/Render/Core/Pipeline.hs index 724b391..ee9c7d2 100644 --- a/Spear/Render/Core/Pipeline.hs +++ b/Spear/Render/Core/Pipeline.hs @@ -13,8 +13,9 @@ module Spear.Render.Core.Pipeline ) where -import Data.Bits ((.|.)) -import Data.List (foldl') +import Control.Monad.IO.Class +import Data.Bits ((.|.)) +import Data.List (foldl') import Graphics.GL.Core46 @@ -24,7 +25,7 @@ data BufferTarget | StencilBuffer -clearBuffers :: [BufferTarget] -> IO () +clearBuffers :: MonadIO io => [BufferTarget] -> io () clearBuffers = glClear . toBufferBitfield where toBufferBitfield = foldl' (.|.) 0 . (<$>) toGLEnum toGLEnum target = case target of @@ -32,28 +33,28 @@ clearBuffers = glClear . toBufferBitfield DepthBuffer -> GL_DEPTH_BUFFER_BIT StencilBuffer -> GL_STENCIL_BUFFER_BIT -setBlending :: Bool -> IO () +setBlending :: MonadIO io => Bool -> io () setBlending enable = if enable then glEnable GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA else glDisable GL_BLEND -setClearColour :: (Float, Float, Float, Float) -> IO () +setClearColour :: MonadIO io => (Float, Float, Float, Float) -> io () setClearColour (r,g,b,a) = glClearColor r g b a -setClearDepth :: Double -> IO () +setClearDepth :: MonadIO io => Double -> io () setClearDepth = glClearDepth -setClearStencil :: Int -> IO () +setClearStencil :: MonadIO io => Int -> io () setClearStencil = glClearStencil . fromIntegral -setCulling :: Bool -> IO () +setCulling :: MonadIO io => Bool -> io () setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE -setDepthMask :: Bool -> IO () +setDepthMask :: MonadIO io => Bool -> io () setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE) -setPolygonOffset :: Float -> Float -> IO () +setPolygonOffset :: MonadIO io => Float -> Float -> io () setPolygonOffset scale bias = do glPolygonOffset scale bias if scale /= 0 && bias /= 0 @@ -61,6 +62,7 @@ setPolygonOffset scale bias = do else glDisable GL_POLYGON_OFFSET_FILL setViewport :: + MonadIO io => -- | x Int -> -- | y @@ -69,6 +71,6 @@ setViewport :: Int -> -- | height Int -> - IO () + io () setViewport x y width height = glViewport (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height) diff --git a/Spear/Render/Core/Shader.hs b/Spear/Render/Core/Shader.hs index 21db66f..32a3cb1 100644 --- a/Spear/Render/Core/Shader.hs +++ b/Spear/Render/Core/Shader.hs @@ -20,6 +20,7 @@ import Spear.Math.Vector import Spear.Render.Core.State import Control.Monad (mapM_) +import Control.Monad.IO.Class import Data.Bits import Data.Hashable import Data.HashMap as HashMap @@ -146,22 +147,22 @@ deleteShaderProgram program = do shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)}) release' program -activateShaderProgram :: ShaderProgram -> IO () +activateShaderProgram :: MonadIO io => ShaderProgram -> io () activateShaderProgram program = do glUseProgram . shaderProgramHandle $ program applyUniforms program -deactivateShaderProgram :: ShaderProgram -> IO () +deactivateShaderProgram :: MonadIO io => ShaderProgram -> io () deactivateShaderProgram _ = glUseProgram 0 -setUniform :: ShaderUniform -> ShaderProgram -> IO () -setUniform uniform program = +setUniform :: MonadIO io => ShaderUniform -> ShaderProgram -> io () +setUniform uniform program = liftIO $ modifyIORef (shaderProgramUniforms program) (setUniform' . removeUniform) where removeUniform = deleteBy matchesUniform uniform matchesUniform uniform u = uniformName u == uniformName uniform setUniform' = (:) uniform -applyUniforms :: ShaderProgram -> IO () +applyUniforms :: MonadIO io => ShaderProgram -> io () applyUniforms program = let update (FloatUniform name value) = glGetUniformLocation' handle name >>= @@ -181,7 +182,7 @@ applyUniforms program = \location -> withArray mat4s $ \ptrMat4s -> glUniformMatrix4fv location (fromIntegral $ length mat4s) GL_FALSE (unsafeCoerce ptrMat4s) handle = shaderProgramHandle program - in do + in liftIO $ do uniforms <- readIORef (shaderProgramUniforms program) mapM_ update uniforms writeIORef (shaderProgramUniforms program) [] @@ -189,7 +190,7 @@ applyUniforms program = -- Private glGetUniformLocation' :: GLuint -> String -> IO GLint -glGetUniformLocation' handle name = +glGetUniformLocation' handle name = liftIO $ withCString name $ \nameCStr -> glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr) diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs index 26f6513..b3a8998 100644 --- a/Spear/Render/Immediate.hs +++ b/Spear/Render/Immediate.hs @@ -79,22 +79,21 @@ deleteImmRenderer immState = do immStart :: Game ImmRenderState () immStart = do state <- get - liftIO $ activateShaderProgram (shader state) + activateShaderProgram (shader state) immEnd :: Game ImmRenderState () immEnd = do state <- get - liftIO $ deactivateShaderProgram (shader state) + deactivateShaderProgram (shader state) immDrawTriangles :: [Vector3] -> Game ImmRenderState () immDrawTriangles vertices = do unless (null vertices) $ do loadMatrixStack state <- get - liftIO $ do - setPositions (triangles state) vertices - applyUniforms (shader state) - renderGeometry (triangles state) + setPositions (triangles state) vertices + applyUniforms (shader state) + renderGeometry (triangles state) -- NOTE: consider using triangle strips for quads. This will require a separate -- Geometry. Using Vector3 for everything currently makes this simple. @@ -137,17 +136,17 @@ immPreservingMatrix f = do immSetColour :: Vector4 -> Game ImmRenderState () immSetColour colour = do state <- get - liftIO $ setUniform (Vec4Uniform "Colour" colour) (shader state) + setUniform (Vec4Uniform "Colour" colour) (shader state) immSetModelMatrix :: Matrix4 -> Game ImmRenderState () immSetModelMatrix model = do state <- get - liftIO $ setUniform (Mat4Uniform "Model" model) (shader state) + setUniform (Mat4Uniform "Model" model) (shader state) immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState () immSetViewProjectionMatrix viewProjection = do state <- get - liftIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state) + setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state) -- Private diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index 4bbbde0..5f96f8c 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs @@ -58,7 +58,7 @@ validate _ = Nothing -- | Load the scene described by the given 'SceneGraph'. resourceMap :: SceneGraph -> Game s SceneResources -resourceMap g = execSubGame (resourceMap' g) emptySceneResources +resourceMap g = exec runSubGame emptySceneResources (resourceMap' g) resourceMap' :: SceneGraph -> Loader () resourceMap' node@(SceneLeaf nid props) = do diff --git a/Spear/Sound/Sound.hs b/Spear/Sound/Sound.hs index 53a1a46..832ffb8 100644 --- a/Spear/Sound/Sound.hs +++ b/Spear/Sound/Sound.hs @@ -16,9 +16,10 @@ where import Spear.Game import Spear.Sound.State -import Data.Set as Set -import Data.StateVar (($=)) -import qualified Sound.ALUT as AL +import Control.Monad.IO.Class +import Data.Set as Set +import Data.StateVar (($=)) +import qualified Sound.ALUT as AL data LoopMode @@ -86,16 +87,16 @@ deleteSoundSource source = do release' source -- | Set the sound that the sound source emits. -setSoundSourceBuffer :: SoundSource -> SoundBuffer -> IO () +setSoundSourceBuffer :: MonadIO io => SoundSource -> SoundBuffer -> io () setSoundSourceBuffer source buffer = AL.buffer (alSource source) $= Just (alBuffer buffer) -- | Set the sound's loop mode. -setSoundLoopMode :: SoundSource -> LoopMode -> IO () +setSoundLoopMode :: MonadIO io => SoundSource -> LoopMode -> io () setSoundLoopMode source mode = AL.loopingMode (alSource source) $= alMode mode where alMode SingleShot = AL.OneShot alMode Loop = AL.Looping -- | Play the sound sources. -playSounds :: [SoundSource] -> IO () +playSounds :: MonadIO io => [SoundSource] -> io () playSounds = AL.play . (alSource <$>) diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc index fb18521..46a692d 100644 --- a/Spear/Sys/Timer.hsc +++ b/Spear/Sys/Timer.hsc @@ -25,6 +25,7 @@ import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr import Foreign.Storable import Control.Monad +import Control.Monad.IO.Class import System.IO.Unsafe #include "Timer/timer.h" @@ -134,22 +135,22 @@ withTimer' c_func timer = alloca $ \ptr -> do peek ptr -- | Construct a new timer. -newTimer :: IO Timer -newTimer = alloca $ \ptr -> do +newTimer :: MonadIO io => io Timer +newTimer = liftIO . alloca $ \ptr -> do c_timer_make ptr peek ptr -- | Start the timer. -start :: Timer -> IO () -start = withTimer c_timer_start +start :: MonadIO io => Timer -> io () +start = liftIO . withTimer c_timer_start -- | Update the timer. -tick :: Timer -> IO Timer -tick = withTimer' c_timer_tick +tick :: MonadIO io => Timer -> io Timer +tick = liftIO . withTimer' c_timer_tick -- | Get the current time. -now :: IO TimePoint -now = alloca $ \ptr -> do +now :: MonadIO io => io TimePoint +now = liftIO . alloca $ \ptr -> do c_time_now ptr peek ptr @@ -186,5 +187,5 @@ timeAdd t dt = unsafeDupablePerformIO $ peek ptr -- | Put the caller thread to sleep for the given amount of time. -sleep :: TimeDelta -> IO () -sleep = c_time_sleep +sleep :: MonadIO io => TimeDelta -> io () +sleep = liftIO . c_time_sleep diff --git a/Spear/Window.hs b/Spear/Window.hs index 75a38f7..a873362 100644 --- a/Spear/Window.hs +++ b/Spear/Window.hs @@ -34,6 +34,7 @@ import Spear.Game import Control.Concurrent.MVar import Control.Exception import Control.Monad (foldM, unless, void, when) +import Control.Monad.IO.Class import Data.Functor ((<&>)) import Data.Maybe (fromJust, fromMaybe, isJust) import qualified Graphics.UI.GLFW as GLFW @@ -76,12 +77,8 @@ data Window = Window } -withWindow :: - Dimensions -> - WindowTitle -> - (Window -> IO a) -> - IO a -withWindow dim@(w, h) windowTitle run = do +withWindow :: MonadIO io => Dimensions -> WindowTitle -> (Window -> IO a) -> io a +withWindow dim@(w, h) windowTitle run = liftIO $ do window <- do success <- GLFW.init unless success $ throw (WindowException "GLFW.initialize failed") @@ -91,11 +88,8 @@ withWindow dim@(w, h) windowTitle run = do GLFW.terminate return result -setup :: - Dimensions -> - WindowTitle -> - IO Window -setup (w, h) windowTitle = do +setup :: MonadIO io => Dimensions -> WindowTitle -> io Window +setup (w, h) windowTitle = liftIO $ do closeRequest <- newEmptyMVar windowEvents <- newEmptyMVar inputEvents <- newEmptyMVar @@ -125,14 +119,14 @@ setup (w, h) windowTitle = do return $ Window window closeRequest inputEvents windowEvents -- | Poll for input events. -pollInputEvents :: Window -> IO [InputEvent] -pollInputEvents window = do +pollInputEvents :: MonadIO io => Window -> io [InputEvent] +pollInputEvents window = liftIO $ do GLFW.pollEvents getEvents (inputEventsMVar window) -- | Poll for window events. -pollWindowEvents :: Window -> IO [WindowEvent] -pollWindowEvents window = do +pollWindowEvents :: MonadIO io => Window -> io [WindowEvent] +pollWindowEvents window = liftIO $ do GLFW.pollEvents getEvents (windowEventsMVar window) @@ -144,16 +138,16 @@ getEvents mvar = tryTakeMVar mvar >>= \xs -> do Just events -> return events -- | Return true when the user requests to close the window. -shouldWindowClose :: Window -> IO Bool -shouldWindowClose = getRequest . closeRequestMVar +shouldWindowClose :: MonadIO io => Window -> io Bool +shouldWindowClose = liftIO . getRequest . closeRequestMVar -- | Swaps buffers. -swapBuffers :: Window -> IO () -swapBuffers = GLFW.swapBuffers . glfwWindow +swapBuffers :: MonadIO io => Window -> io () +swapBuffers = liftIO . GLFW.swapBuffers . glfwWindow -- | Get the window's size. -getWindowSize :: Window -> IO (Width, Height) -getWindowSize = GLFW.getWindowSize . glfwWindow +getWindowSize :: MonadIO io => Window -> io (Width, Height) +getWindowSize = liftIO . GLFW.getWindowSize . glfwWindow getRequest :: MVar Bool -> IO Bool getRequest mvar = -- cgit v1.2.3