Simplify Game monad.

15 files changed, 238 insertions, 244 deletions

diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index de8e6f2..df90020 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -41,16 +41,16 @@ initGame window = do
 
 endGame :: Game GameState ()
 endGame = do
-  game <- getGameState
+  game <- get
   runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
 
 
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
-  gs <- getGameState
+  gs <- get
   events <- processInput (window gs)
-  --when (events /= []) $ gameIO . putStrLn $ show events
-  modifyGameState $ \gs ->
+  --when (events /= []) $ liftIO . putStrLn $ show events
+  modify $ \gs ->
     gs
       { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
       }
@@ -67,18 +67,18 @@ exitRequested = elem (KeyDown KEY_ESC)
 
 render :: Game GameState ()
 render = do
-  gameState <- getGameState
+  gameState <- get
   immRenderState' <- flip execSubGame (immRenderState gameState) $ do
     immStart
     immSetViewProjectionMatrix (viewProjection gameState)
     -- Clear the background to a different colour than the playable area to make
     -- the latter distinguishable.
-    gameIO $ do
+    liftIO $ do
       setClearColour (0.2, 0.2, 0.2, 0.0)
       clearBuffers [ColourBuffer]
     render' $ world gameState
     immEnd
-  saveGameState $ gameState { immRenderState = immRenderState' }
+  put $ gameState { immRenderState = immRenderState' }
 
 render' :: [GameObject] -> Game ImmRenderState ()
 render' world = do
@@ -122,7 +122,7 @@ resize (ResizeEvent w h) =
       bottom = if r > 1 then 0 else -pad
       top    = if r > 1 then 1 else 1 + pad
   in do
-    gameIO $ setViewport 0 0 w h
-    modifyGameState $ \state -> state {
+    liftIO $ setViewport 0 0 w h
+    modify $ \state -> state {
       viewProjection = Matrix4.ortho left right bottom top (-1) 1
     }
diff --git a/Spear/App.hs b/Spear/App.hs
index 61ea3b1..1520eee 100644
--- a/Spear/App.hs
+++ b/Spear/App.hs
@@ -76,15 +76,15 @@ loop :: App s -> Window -> Game s ()
 loop app window = do
   -- For convenience, trigger an initial resize followed by a render of the
   -- application's initial state.
-  (width, height) <- gameIO $ getWindowSize window
+  (width, height) <- liftIO $ 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 <- gameIO newTimer
-  gameIO $ Timer.start timer
+  timer <- liftIO newTimer
+  liftIO $ Timer.start timer
   let lastAnimationTime = lastTick timer
   loop' window ddt animationDdt lastAnimationTime timer app
 
@@ -97,16 +97,16 @@ loop' ::
   App s ->
   Game s ()
 loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do
-  timer        <- gameIO $ tick inputTimer
-  windowEvents <- gameIO $ pollWindowEvents window
-  close        <- gameIO $ shouldWindowClose window
+  timer        <- liftIO $ tick inputTimer
+  windowEvents <- liftIO $ pollWindowEvents window
+  close        <- liftIO $ 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 <- gameIO $ pollInputEvents window
+      inputEvents <- liftIO $ pollInputEvents window
       continue <- stepApp app t dt inputEvents
       return (continue, lastAnimationTime)
 
@@ -118,15 +118,15 @@ loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do
       let timeBudgetThisFrame = timeBudget + deltaTime timer
       let timeBudgetNextFrame = timeBudgetThisFrame `mod` ddt
       let steps = timeBudgetThisFrame `div` ddt -}
-      --gameIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
+      --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
       let elapsed = runningTime timer
       let dt = timeDeltaToSec ddt
       let timeBudgetThisFrame = timeDiff lastAnimationTime (lastTick timer)
       let steps = timeBudgetThisFrame `div` ddt
       let lastAnimationTimeNextFrame = timeAdd lastAnimationTime (steps * ddt)
-      --gameIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
+      --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt
       continue <- and <$> forM [1..steps] (\i -> do
-        inputEvents <- gameIO $ pollInputEvents window
+        inputEvents <- liftIO $ pollInputEvents window
         let t = timeDeltaToSec $ elapsed + i * ddt
         stepApp app t dt inputEvents)
       return (continue, lastAnimationTimeNextFrame)
@@ -138,16 +138,16 @@ loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do
   -- For smoother resizing, render only while not resizing.
   unless resized $ do
     renderApp app
-    gameIO $ swapBuffers window
+    liftIO $ 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 <- gameIO now
+    frameEnd <- liftIO now
     let ddt = renderDdt
     let frameTime = timeDiff (lastTick timer) frameEnd
     when (frameTime < ddt) $ do
-      gameIO $ Timer.sleep (ddt - frameTime)
+      liftIO $ Timer.sleep (ddt - frameTime)
 
   when (continue && not close) $ do
     loop' window renderDdt animationDdt lastAnimationTimeNextFrame timer app
diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc
index f9fc025..db90afe 100644
--- a/Spear/Assets/Image.hsc
+++ b/Spear/Assets/Image.hsc
@@ -46,24 +46,24 @@ data CImage = CImage
 instance Storable CImage where

     sizeOf _    = #{size Image}

     alignment _ = alignment (undefined :: CInt)

-    

+

     peek ptr = do

         width  <- #{peek Image, width}  ptr

         height <- #{peek Image, height} ptr

         bpp    <- #{peek Image, bpp}    ptr

         pixels <- #{peek Image, pixels} ptr

         return $ CImage width height bpp pixels

-    

+

     poke ptr (CImage width height bpp pixels) = do

         #{poke Image, width}  ptr width

         #{poke Image, height} ptr height

         #{poke Image, bpp}    ptr bpp

         #{poke Image, pixels} ptr pixels

 

--- | Represents an image 'Resource'.

+-- | An image resource.

 data Image = Image

     { imageData :: CImage

-    , rkey      :: Resource

+    , rkey      :: ReleaseKey

     }

 

 instance ResourceClass Image where

@@ -84,15 +84,15 @@ loadImage file = do
     dotPos <- case elemIndex '.' file of

             Nothing -> gameError $ "file name has no extension: " ++ file

             Just p  -> return p

-    

+

     let ext = map toLower . tail . snd $ splitAt dotPos file

-    

-    result <- gameIO . alloca $ \ptr -> do

+

+    result <- liftIO . alloca $ \ptr -> do

         status <- withCString file $ \fileCstr -> do

             case ext of

                 "bmp" -> bmp_load fileCstr ptr

                 _     -> return ImageNoSuitableLoader

-        

+

         case status of

             ImageSuccess               -> peek ptr >>= return . Right

             ImageReadError             -> return . Left $ "read error"

@@ -100,7 +100,7 @@ loadImage file = do
             ImageFileNotFound          -> return . Left $ "file not found"

             ImageInvalidFormat         -> return . Left $ "invalid format"

             ImageNoSuitableLoader      -> return . Left $ "no suitable loader for extension " ++ ext

-        

+

     case result of

         Right image -> register (freeImage image) >>= return . Image image

         Left  err   -> gameError $ "loadImage: " ++ err

diff --git a/Spear/Assets/Model.hsc b/Spear/Assets/Model.hsc
index 74666f2..02e1edf 100644
--- a/Spear/Assets/Model.hsc
+++ b/Spear/Assets/Model.hsc
@@ -65,12 +65,12 @@ data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float
 instance Storable Vec2 where

     sizeOf _ = 2*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         return $ Vec2 f0 f1

-    

+

     poke ptr (Vec2 f0 f1) = do

         pokeByteOff ptr 0         f0

         pokeByteOff ptr sizeFloat f1

@@ -81,13 +81,13 @@ data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Flo
 instance Storable Vec3 where

     sizeOf _ = 3*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         f2 <- peekByteOff ptr (2*sizeFloat)

         return $ Vec3 f0 f1 f2

-    

+

     poke ptr (Vec3 f0 f1 f2) = do

         pokeByteOff ptr 0             f0

         pokeByteOff ptr sizeFloat     f1

@@ -99,12 +99,12 @@ data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float
 instance Storable TexCoord where

     sizeOf _ = 2*sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         f0 <- peekByteOff ptr 0

         f1 <- peekByteOff ptr sizeFloat

         return $ TexCoord f0 f1

-    

+

     poke ptr (TexCoord f0 f1) = do

         pokeByteOff ptr 0         f0

         pokeByteOff ptr sizeFloat f1

@@ -122,23 +122,23 @@ data CTriangle = CTriangle
 instance Storable CTriangle where

     sizeOf _ = #{size triangle}

     alignment _ = alignment (undefined :: CUShort)

-    

+

     peek ptr = do

         v0 <- #{peek triangle, vertexIndices[0]} ptr

         v1 <- #{peek triangle, vertexIndices[1]} ptr

         v2 <- #{peek triangle, vertexIndices[2]} ptr

-        

+

         t0 <- #{peek triangle, textureIndices[0]} ptr

         t1 <- #{peek triangle, textureIndices[1]} ptr

         t2 <- #{peek triangle, textureIndices[2]} ptr

-        

+

         return $ CTriangle v0 v1 v2 t0 t1 t2

-    

+

     poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do

         #{poke triangle, vertexIndices[0]} ptr v0

         #{poke triangle, vertexIndices[1]} ptr v1

         #{poke triangle, vertexIndices[2]} ptr v2

-        

+

         #{poke triangle, textureIndices[0]} ptr t0

         #{poke triangle, textureIndices[1]} ptr t1

         #{poke triangle, textureIndices[2]} ptr t2

@@ -149,7 +149,7 @@ data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3
 instance Storable Box where

     sizeOf _ = 6 * sizeFloat

     alignment _ = alignment (undefined :: CFloat)

-    

+

     peek ptr = do

         xmin <- peekByteOff ptr 0

         ymin <- peekByteOff ptr sizeFloat

@@ -158,7 +158,7 @@ instance Storable Box where
         ymax <- peekByteOff ptr $ 4*sizeFloat

         zmax <- peekByteOff ptr $ 5*sizeFloat

         return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)

-    

+

     poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do

         pokeByteOff ptr 0             xmin

         pokeByteOff ptr sizeFloat     ymin

@@ -173,11 +173,11 @@ newtype Skin = Skin { skinName :: B.ByteString }
 instance Storable Skin where

     sizeOf (Skin s) = 64

     alignment _ = 1

-    

+

     peek ptr = do

         s <- B.packCString $ unsafeCoerce ptr

         return $ Skin s

-    

+

     poke ptr (Skin s) = do

         B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len

 

@@ -193,13 +193,13 @@ data Animation = Animation
 instance Storable Animation where

     sizeOf _    = #{size animation}

     alignment _ = alignment (undefined :: CUInt)

-    

+

     peek ptr = do

         name  <- B.packCString (unsafeCoerce ptr)

         start <- #{peek animation, start} ptr

         end   <- #{peek animation, end}   ptr

         return $ Animation name start end

-    

+

     poke ptr (Animation name start end) = do

         B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len

         #{poke animation, start} ptr start

@@ -224,7 +224,7 @@ data Model = Model
 instance Storable Model where

     sizeOf _    = #{size Model}

     alignment _ = alignment (undefined :: CUInt)

-    

+

     peek ptr = do

         numFrames     <- #{peek Model, numFrames}     ptr

         numVertices   <- #{peek Model, numVertices}   ptr

@@ -232,7 +232,7 @@ instance Storable Model where
         numTexCoords  <- #{peek Model, numTexCoords}  ptr

         numSkins      <- #{peek Model, numSkins}      ptr

         numAnimations <- #{peek Model, numAnimations} ptr

-        pVerts        <- peek (unsafeCoerce ptr) 

+        pVerts        <- peek (unsafeCoerce ptr)

         pNormals      <- peekByteOff ptr sizePtr

         pTexCoords    <- peekByteOff ptr (2*sizePtr)

         pTriangles    <- peekByteOff ptr (3*sizePtr)

@@ -247,7 +247,7 @@ instance Storable Model where
         return $

             Model vertices normals texCoords triangles skins animations

                   numFrames numVertices numTriangles numTexCoords numSkins numAnimations

-    

+

     poke ptr

         (Model verts normals texCoords tris skins animations

          numFrames numVerts numTris numTex numSkins numAnimations) =

@@ -288,7 +288,7 @@ data Triangle = Triangle
 instance Storable Triangle where

     sizeOf _ = #{size model_triangle}

     alignment _ = alignment (undefined :: Float)

-    

+

     peek ptr = do

         v0 <- #{peek model_triangle, v0} ptr

         v1 <- #{peek model_triangle, v1} ptr

@@ -300,7 +300,7 @@ instance Storable Triangle where
         t1 <- #{peek model_triangle, t1} ptr

         t2 <- #{peek model_triangle, t2} ptr

         return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2

-    

+

     poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do

         #{poke model_triangle, v0} ptr v0

         #{poke model_triangle, v1} ptr v1

@@ -335,16 +335,16 @@ loadModel file = do
     dotPos <- case elemIndex '.' file of

             Nothing -> gameError $ "file name has no extension: " ++ file

             Just p  -> return p

-    

+

     let ext = map toLower . tail . snd $ splitAt dotPos file

-    

-    result <- gameIO . alloca $ \ptr -> do

+

+    result <- liftIO . alloca $ \ptr -> do

         status <- withCString file $ \fileCstr -> do

             case ext of

                 "md2" -> md2_load fileCstr 0 0 ptr

                 "obj" -> obj_load fileCstr 0 0 ptr

                 _     -> return ModelNoSuitableLoader

-        

+

         case status of

             ModelSuccess -> do

                 model <- peek ptr

@@ -355,7 +355,7 @@ loadModel file = do
             ModelFileNotFound           -> return . Left $ "file not found"

             ModelFileMismatch           -> return . Left $ "file mismatch"

             ModelNoSuitableLoader       -> return . Left $ "no suitable loader for extension " ++ ext

-    

+

     case result of

         Right model -> return model

         Left err    -> gameError $ "loadModel: " ++ err

@@ -392,7 +392,7 @@ transformVerts model f = model { vertices = vertices' }
     where

         n = numVerts model * numFrames model

         vertices' = S.generate n f'

-        f' i = f $ vertices model S.! i 

+        f' i = f $ vertices model S.! i

 

 -- | Transform the model's normals.

 transformNormals :: Model -> (Vec3 -> Vec3) -> Model

@@ -400,14 +400,14 @@ transformNormals model f = model { normals = normals' }
     where

         n = numVerts model * numFrames model

         normals' = S.generate n f'

-        f' i = f $ normals model S.! i 

+        f' i = f $ normals model S.! i

 

 -- | Translate the model such that its lowest point has y = 0.

 toGround :: Model -> IO Model

 toGround model =

     let model' = model { vertices = S.generate n $ \i -> vertices model S.! i }

         n = numVerts model * numFrames model

-    in    

+    in

         with model' model_to_ground >> return model'

 

 foreign import ccall "Model.h model_to_ground"

diff --git a/Spear/GL.hs b/Spear/GL.hs
index f463109..3c1734b 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -36,7 +36,7 @@ module Spear.GL
     Data.StateVar.get,

 

     -- * VAOs

-    VAO,

+    VAO(..),

     newVAO,

     bindVAO,

     unbindVAO,

@@ -48,7 +48,7 @@ module Spear.GL
     drawElements,

 

     -- * Buffers

-    GLBuffer,

+    GLBuffer(..),

     TargetBuffer (..),

     BufferUsage (..),

     newBuffer,

@@ -122,7 +122,7 @@ import           Unsafe.Coerce
 -- | A GLSL shader handle.

 data GLSLShader = GLSLShader

   { getShader    :: GLuint,

-    getShaderKey :: Resource

+    getShaderKey :: ReleaseKey

   }

 

 instance ResourceClass GLSLShader where

@@ -131,7 +131,7 @@ instance ResourceClass GLSLShader where
 -- | A GLSL program handle.

 data GLSLProgram = GLSLProgram

   { getProgram    :: GLuint,

-    getProgramKey :: Resource

+    getProgramKey :: ReleaseKey

   }

 

 instance ResourceClass GLSLProgram where

@@ -173,11 +173,11 @@ attribLocation prog var = makeStateVar get set
 -- | Create a new program.

 newProgram :: [GLSLShader] -> Game s GLSLProgram

 newProgram shaders = do

-  h <- gameIO glCreateProgram

+  h <- liftIO glCreateProgram

   when (h == 0) $ gameError "glCreateProgram failed"

   rkey <- register $ deleteProgram h

   let program = GLSLProgram h rkey

-  mapM_ (gameIO . attachShader program) shaders

+  mapM_ (liftIO . attachShader program) shaders

   linkProgram program

   return program

 

@@ -192,7 +192,7 @@ deleteProgram prog = do
 linkProgram :: GLSLProgram -> Game s ()

 linkProgram prog = do

   let h = getProgram prog

-  err <- gameIO $ do

+  err <- liftIO $ do

     glLinkProgram h

     alloca $ \statptr -> do

       glGetProgramiv h GL_LINK_STATUS statptr

@@ -235,7 +235,7 @@ loadShader shaderType file = do
 -- | Create a new shader.

 newShader :: ShaderType -> Game s GLSLShader

 newShader shaderType = do

-  h <- gameIO $ glCreateShader (toGLShader shaderType)

+  h <- liftIO $ glCreateShader (toGLShader shaderType)

   case h of

     0 -> gameError "glCreateShader failed"

     _ -> do

@@ -253,10 +253,10 @@ deleteShader shader = do
 -- into the shader.

 loadSource :: FilePath -> GLSLShader -> Game s ()

 loadSource file h = do

-  exists <- gameIO $ doesFileExist file

+  exists <- liftIO $ doesFileExist file

   case exists of

     False -> gameError "the specified shader file does not exist"

-    True -> gameIO $ do

+    True -> liftIO $ do

       code <- readSource file

       withCString code $ shaderSource h

 

@@ -272,10 +272,10 @@ compile file shader = do
   let h = getShader shader

 

   -- Compile

-  gameIO $ glCompileShader h

+  liftIO $ glCompileShader h

 

   -- Verify status

-  err <- gameIO $

+  err <- liftIO $

     alloca $ \statusPtr -> do

       glGetShaderiv h GL_COMPILE_STATUS statusPtr

       result <- peek statusPtr

@@ -438,7 +438,7 @@ instance Uniform [Int] where
 -- | A vertex array object.

 data VAO = VAO

   { getVAO :: GLuint,

-    vaoKey :: Resource

+    vaoKey :: ReleaseKey

   }

 

 instance ResourceClass VAO where

@@ -454,7 +454,7 @@ instance Ord VAO where
 -- | Create a new vao.

 newVAO :: Game s VAO

 newVAO = do

-  h <- gameIO . alloca $ \ptr -> do

+  h <- liftIO . alloca $ \ptr -> do

     glGenVertexArrays 1 ptr

     peek ptr

 

@@ -533,11 +533,11 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
 -- | An OpenGL buffer.

 data GLBuffer = GLBuffer

   { getBuffer :: GLuint,

-    rkey      :: Resource

+    bufferKey :: ReleaseKey

   }

 

 instance ResourceClass GLBuffer where

-  getResource = rkey

+  getResource = bufferKey

 

 -- | The type of target buffer.

 data TargetBuffer

@@ -580,7 +580,7 @@ fromUsage DynamicCopy = GL_DYNAMIC_COPY
 -- | Create a new buffer.

 newBuffer :: Game s GLBuffer

 newBuffer = do

-  h <- gameIO . alloca $ \ptr -> do

+  h <- liftIO . alloca $ \ptr -> do

     glGenBuffers 1 ptr

     peek ptr

 

@@ -656,7 +656,7 @@ withGLBuffer buf f = f $ getBuffer buf
 -- | Represents a texture resource.

 data Texture = Texture

   { getTex :: GLuint,

-    texKey :: Resource

+    texKey :: ReleaseKey

   }

 

 instance Eq Texture where

@@ -672,7 +672,7 @@ instance ResourceClass Texture where
 -- | Create a new texture.

 newTexture :: Game s Texture

 newTexture = do

-  tex <- gameIO . alloca $ \ptr -> do

+  tex <- liftIO . alloca $ \ptr -> do

     glGenTextures 1 ptr

     peek ptr

 

@@ -697,7 +697,7 @@ loadTextureImage ::
 loadTextureImage file minFilter magFilter = do

   image <- loadImage file

   tex <- newTexture

-  gameIO $ do

+  liftIO $ do

     let w = width image

         h = height image

         pix = pixels image

@@ -794,7 +794,7 @@ printGLError =
 assertGL :: Game s a -> String -> Game s a

 assertGL action err = do

   result <- action

-  status <- gameIO getGLError

+  status <- liftIO getGLError

   case status of

     Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str

     Nothing  -> return result

diff --git a/Spear/Game.hs b/Spear/Game.hs
index 14e3f20..92cc680 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -1,130 +1,130 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

 module Spear.Game

-  ( Game,

-    GameException (..),

-    Resource,

-    ResourceClass (..),

-

-    -- * Game state

-    getGameState,

-    saveGameState,

-    modifyGameState,

-

-    -- * Game resources

-    register,

-    release,

-    release',

-

-    -- * Error handling

-    gameError,

-    assertMaybe,

-    catchGameError,

-    catchGameErrorFinally,

-

-    -- * Running and IO

-    runGame,

-    evalGame,

-    runSubGame,

-    runSubGame',

-    evalSubGame,

-    execSubGame,

-    runSiblingGame,

-    runSiblingGame',

-    evalSiblingGame,

-    execSiblingGame,

-    gameIO,

-  )

+( Game

+, GameException (..)

+, ResourceClass (..)

+, ReleaseKey

+  -- * Game state

+, get

+, put

+, modify

+  -- * Game resources

+, register

+, release

+, release'

+  -- * Error handling

+, gameError

+, assertMaybe

+, catch

+  -- * Running and IO

+, runGame

+, evalGame

+, runSubGame

+, runSubGame'

+, evalSubGame

+, execSubGame

+, runSiblingGame

+, runSiblingGame'

+, evalSiblingGame

+, execSiblingGame

+, liftIO

+)

 where

 

 import           Control.Monad.Catch

 import           Control.Monad.State.Strict

 import           Control.Monad.Trans.Class    (lift)

-import qualified Control.Monad.Trans.Resource as R

-

+import           Control.Monad.Trans.Resource

 

-type Resource = R.ReleaseKey

 

+-- | Anything that holds a resource.

+--

+-- This is a convenient wrapper so that we can define the general `release'`

+-- function on any type of resource.

 class ResourceClass a where

-  getResource :: a -> Resource

+  getResource :: a -> ReleaseKey

 

-type Game s = StateT s (R.ResourceT IO)

 

+-- | A game exception.

+--

+-- This is mostly a convenient wrapper around `String` so that we can throw

+-- strings directly with `gameError`.

 newtype GameException = GameException String deriving (Show)

 

 instance Exception GameException

 

 

--- | Retrieve the game state.

-getGameState :: Game s s

-getGameState = get

-

--- | Save the game state.

-saveGameState :: s -> Game s ()

-saveGameState = put

-

--- | Modify the game state.

-modifyGameState :: (s -> s) -> Game s ()

-modifyGameState = modify

-

--- | Register the given cleaner.

-register :: IO () -> Game s Resource

-register = lift . R.register

+-- | The game monad.

+--

+-- The game monad performs three different roles:

+--

+--   1. I/O

+--   2. Resource management.

+--   3. State management.

+newtype Game s a = Game { getGame :: StateT s (ResourceT IO) a }

+  deriving

+  ( Functor

+  , Applicative

+  , Monad

+  , MonadIO

+  , MonadThrow

+  , MonadCatch

+  , MonadState s

+  , MonadResource

+  )

 

--- | Release the given 'Resource'.

-release :: ResourceClass a => a -> Game s ()

-release = lift . R.release . getResource

 

 -- | Release the given 'Resource'.

-release' :: ResourceClass a => a -> IO ()

-release' = R.release . getResource

+release' :: ResourceClass a => a -> Game s ()

+release' = release . getResource

 

 -- | Throw an error from the 'Game' monad.

 gameError :: String -> Game s a

-gameError = gameError' . GameException

-

--- | Throw an error from the 'Game' monad.

-gameError' :: GameException -> Game s a

-gameError' = lift . lift . throwM

+gameError = throwM . GameException

 

 -- | Throw the given error if given 'Nothing'.

 assertMaybe :: Maybe a -> GameException -> Game s a

-assertMaybe Nothing err = gameError' err

+assertMaybe Nothing err = throwM err

 assertMaybe (Just x) _  = return x

 

--- | Run the given game with the given error handler.

-catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a

-catchGameError = catch

-

--- | Run the given game, catch any error, run the given finaliser and rethrow the error.

-catchGameErrorFinally :: Game s a -> Game s a -> Game s a

-catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err

-

--- | Run the given game.

+-- | Run the given game, unrolling the full monad stack and returning the game's

+-- 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 = R.runResourceT . runStateT game

+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

 

--- | Fully run the given sub game, unrolling the entire monad stack.

+-- | 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 = gameIO $ runGame g 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 result.

-evalSubGame :: Game s a -> s -> Game t a

-evalSubGame g s = fst <$> runSubGame g s

-

--- | Run the given sub game and return its state.

+-- | Run the given sub-game and return its state.

 execSubGame :: Game s a -> s -> Game t s

 execSubGame g s = snd <$> runSubGame g s

 

--- | Run the given sibling game, unrolling StateT but not ResourceT.

+-- | 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 g s = lift $ runStateT g s

+runSiblingGame game = Game . lift . runStateT (getGame game)

 

 -- | Like 'runSiblingGame', but discarding the result.

 runSiblingGame' :: Game s a -> s -> Game t ()

@@ -137,7 +137,3 @@ 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

-

--- | Perform the given IO action in the 'Game' monad.

-gameIO :: IO a -> Game s a

-gameIO = lift . lift

diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index 8f0d6bd..e5b29ec 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -66,7 +66,7 @@ data AnimatedModelResource = AnimatedModelResource
     material  :: Material,

     texture   :: Texture,

     boxes     :: V.Vector Box,

-    rkey      :: Resource

+    rkey      :: ReleaseKey

   }

 

 instance Eq AnimatedModelResource where

@@ -121,12 +121,12 @@ animatedModelResource
   material

   texture

   model = do

-    RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model

+    RenderModel elements numFrames numVertices <- liftIO . renderModelFromModel $ model

     elementBuf <- newBuffer

     vao <- newVAO

-    boxes <- gameIO $ modelBoxes model

+    boxes <- liftIO $ modelBoxes model

 

-    gameIO $ do

+    liftIO $ do

       let elemSize = 56::CUInt

           elemSize' = fromIntegral elemSize

           n = numVertices * numFrames

@@ -149,9 +149,8 @@ animatedModelResource
       enableVAOAttrib texChan

 

     rkey <- register $ do

-      putStrLn "Releasing animated model resource"

-      release' vao

-      release' elementBuf

+      release $ vaoKey vao

+      release $ bufferKey elementBuf

 

     return $

       AnimatedModelResource

diff --git a/Spear/Render/Core/Buffer.hs b/Spear/Render/Core/Buffer.hs
index db3437e..eaff475 100644
--- a/Spear/Render/Core/Buffer.hs
+++ b/Spear/Render/Core/Buffer.hs
@@ -53,19 +53,19 @@ makeBufferAndView desc = do
 
 makeBuffer :: BufferDesc -> Game RenderCoreState Buffer
 makeBuffer (BufferDesc usage bufferData) = do
-  handle <- gameIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr
+  handle <- liftIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr
   resourceKey <- register $ deleteBuffer' handle
   let buffer = Buffer handle resourceKey usage
-  gameIO $ updateBuffer buffer bufferData
-  modifyGameState (\state -> state {
+  liftIO $ updateBuffer buffer bufferData
+  modify (\state -> state {
     buffers = HashMap.insert handle buffer (buffers state) })
   return buffer
 
 deleteBuffer :: Buffer -> Game RenderCoreState ()
 deleteBuffer buffer = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     buffers = HashMap.delete (bufferHandle buffer) (buffers state) })
-  release buffer
+  release' buffer
 
 -- TODO: use glBufferSubData for updates.
 updateBuffer :: Buffer -> BufferData -> IO ()
diff --git a/Spear/Render/Core/Geometry.hs b/Spear/Render/Core/Geometry.hs
index 6c05b38..10ff709 100644
--- a/Spear/Render/Core/Geometry.hs
+++ b/Spear/Render/Core/Geometry.hs
@@ -87,23 +87,23 @@ newGeometryDesc = GeometryDesc
 makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry
 makeGeometry desc = do
   gdata  <- geometryDescToData desc
-  handle <- gameIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr
-  gameIO $ do
+  handle <- liftIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr
+  liftIO $ do
     glBindVertexArray handle
     configureVertexAttributes gdata
     glBindVertexArray 0
-  gdataRef <- gameIO $ newIORef gdata
+  gdataRef <- liftIO $ newIORef gdata
   resourceKey <- register $ deleteGeometry' handle
   let geometry = Geometry handle resourceKey gdataRef
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     geometries = HashMap.insert handle geometry (geometries state) })
   return geometry
 
 deleteGeometry :: Geometry -> Game RenderCoreState ()
 deleteGeometry geometry = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     geometries = HashMap.delete (geometryVao geometry) (geometries state) })
-  release geometry
+  release' geometry
 
 renderGeometry :: Geometry -> IO ()
 renderGeometry geometry = do
diff --git a/Spear/Render/Core/Shader.hs b/Spear/Render/Core/Shader.hs
index 4ed4430..21db66f 100644
--- a/Spear/Render/Core/Shader.hs
+++ b/Spear/Render/Core/Shader.hs
@@ -53,22 +53,22 @@ compileShader :: ShaderDesc -> Game RenderCoreState Shader
 compileShader (ShaderDesc shaderType source defines) = do
   code <- case source of
     ShaderFromString code -> return code
-    ShaderFromFile   file -> gameIO $ readFile file
-  state <- getGameState
+    ShaderFromFile   file -> liftIO $ readFile file
+  state <- get
   let shaderHash = hash code -- TODO: Should also include defines.
   case HashMap.lookup shaderHash (shaders state) of
     Just shader -> return shader
     Nothing -> do
       let definesString = makeDefinesString defines
-      handle <- gameIO $ glCreateShader (toGLShaderType shaderType)
-      gameIO $ withCStringLen code $ \(codeCString, codeLen) ->
+      handle <- liftIO $ glCreateShader (toGLShaderType shaderType)
+      liftIO $ withCStringLen code $ \(codeCString, codeLen) ->
         withCStringLen definesString $ \(definesCString, definesLen) ->
           withCStringLen header $ \(headerCString, headerLen) ->
             withArray [headerCString, definesCString, codeCString] $ \strPtrs ->
               withArray (fromIntegral <$> [headerLen, definesLen, codeLen] :: [GLint])
                 $ \lengths ->
                   glShaderSource handle 3 strPtrs lengths
-      err <- gameIO $ do
+      err <- liftIO $ do
         glCompileShader handle
         alloca $ \statusPtr -> do
           glGetShaderiv handle GL_COMPILE_STATUS statusPtr
@@ -87,7 +87,7 @@ compileShader (ShaderDesc shaderType source defines) = do
         Nothing -> do
           resourceKey <- register $ deleteShader' handle
           let shader = Shader handle resourceKey shaderType shaderHash
-          saveGameState $ state {
+          put $ state {
             shaders = HashMap.insert shaderHash shader (shaders state)
           }
           return shader
@@ -96,17 +96,17 @@ compileShader (ShaderDesc shaderType source defines) = do
 
 compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram
 compileShaderProgram shaders = do
-  state <- getGameState
+  state <- get
   let programHash = hashShaders shaders
   case HashMap.lookup programHash (shaderPrograms state) of
     Just program -> return program
     Nothing -> do
-      handle <- gameIO glCreateProgram
+      handle <- liftIO glCreateProgram
       case handle of
         0 -> gameError "Failed to create shader program"
         _ -> do
-          mapM_ (gameIO . glAttachShader handle) (shaderHandle <$> shaders)
-          err <- gameIO $ do
+          mapM_ (liftIO . glAttachShader handle) (shaderHandle <$> shaders)
+          err <- liftIO $ do
             glLinkProgram handle
             alloca $ \statusPtr -> do
               glGetProgramiv handle GL_LINK_STATUS statusPtr
@@ -124,9 +124,9 @@ compileShaderProgram shaders = do
           case err of
             Nothing -> do
               resourceKey <- register $ deleteShaderProgram' handle
-              uniforms <- gameIO $ newIORef []
+              uniforms <- liftIO $ newIORef []
               let program = ShaderProgram handle resourceKey programHash uniforms
-              saveGameState $ state {
+              put $ state {
                 shaderPrograms = HashMap.insert programHash program (shaderPrograms state)
               }
               return program
@@ -136,15 +136,15 @@ compileShaderProgram shaders = do
 
 deleteShader :: Shader -> Game RenderCoreState ()
 deleteShader shader = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     shaders = HashMap.delete (shaderHash shader) (shaders state) })
-  release shader
+  release' shader
 
 deleteShaderProgram :: ShaderProgram -> Game RenderCoreState ()
 deleteShaderProgram program = do
-  modifyGameState (\state -> state {
+  modify (\state -> state {
     shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)})
-  release program
+  release' program
 
 activateShaderProgram :: ShaderProgram -> IO ()
 activateShaderProgram program = do
diff --git a/Spear/Render/Core/State.hs b/Spear/Render/Core/State.hs
index dac7b9a..aa42635 100644
--- a/Spear/Render/Core/State.hs
+++ b/Spear/Render/Core/State.hs
@@ -18,7 +18,7 @@ data BufferUsage
 -- | A data buffer (e.g., vertex attributes, indices).
 data Buffer = Buffer
   { bufferHandle   :: GLuint
-  , bufferResource :: Resource
+  , bufferResource :: ReleaseKey
   , bufferUsage    :: BufferUsage
   }
 
@@ -72,7 +72,7 @@ data GeometryData = GeometryData
 -- its state cannot become stale after an update.
 data Geometry = Geometry
   { geometryVao      :: GLuint
-  , geometryResource :: Resource
+  , geometryResource :: ReleaseKey
   , geometryData     :: IORef GeometryData
   }
 
@@ -80,7 +80,7 @@ data Geometry = Geometry
 -- | A shader.
 data Shader = Shader
   { shaderHandle   :: GLuint
-  , shaderResource :: Resource
+  , shaderResource :: ReleaseKey
   , shaderType     :: ShaderType
   , shaderHash     :: Int
   }
@@ -102,7 +102,7 @@ data ShaderUniform
 -- | A shader program.
 data ShaderProgram = ShaderProgram
   { shaderProgramHandle   :: GLuint
-  , shaderProgramResource :: Resource
+  , shaderProgramResource :: ReleaseKey
   , shaderProgramHash     :: Int
   -- Dirty set of uniforms that have been set since the last time uniforms were
   -- applied. OpenGL retains the values of uniforms for a program until the
diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs
index 3c5f6ad..26f6513 100644
--- a/Spear/Render/Immediate.hs
+++ b/Spear/Render/Immediate.hs
@@ -78,20 +78,20 @@ deleteImmRenderer immState = do
 
 immStart :: Game ImmRenderState ()
 immStart = do
-  state <- getGameState
-  gameIO $ activateShaderProgram (shader state)
+  state <- get
+  liftIO $ activateShaderProgram (shader state)
 
 immEnd :: Game ImmRenderState ()
 immEnd = do
-  state <- getGameState
-  gameIO $ deactivateShaderProgram (shader state)
+  state <- get
+  liftIO $ deactivateShaderProgram (shader state)
 
 immDrawTriangles :: [Vector3] -> Game ImmRenderState ()
 immDrawTriangles vertices = do
   unless (null vertices) $ do
     loadMatrixStack
-    state <- getGameState
-    gameIO $ do
+    state <- get
+    liftIO $ do
       setPositions (triangles state) vertices
       applyUniforms (shader state)
       renderGeometry (triangles state)
@@ -112,42 +112,42 @@ immDrawQuads2d =
   immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3))
 
 immLoadIdentity :: Game ImmRenderState ()
-immLoadIdentity = modifyGameState $ \state -> state {
+immLoadIdentity = modify $ \state -> state {
   matrixStack = [Matrix4.id] }
 
 immTranslate :: Vector3 -> Game ImmRenderState ()
-immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector)
+immTranslate vector = modify $ pushMatrix (Matrix4.translatev vector)
 
 immPushMatrix :: Matrix4 -> Game ImmRenderState ()
-immPushMatrix matrix = modifyGameState $ pushMatrix matrix
+immPushMatrix matrix = modify $ pushMatrix matrix
 
 immPopMatrix :: Game ImmRenderState ()
-immPopMatrix = modifyGameState $ \state -> state {
+immPopMatrix = modify $ \state -> state {
   matrixStack = case matrixStack state of
     [x]  -> [x] -- Always keep the identity matrix on the stack.
     x:xs -> xs }
 
 immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a
 immPreservingMatrix f = do
-  originalStack <- matrixStack <$> getGameState
+  originalStack <- matrixStack <$> get
   result <- f
-  modifyGameState $ \state -> state { matrixStack = originalStack }
+  modify $ \state -> state { matrixStack = originalStack }
   return result
 
 immSetColour :: Vector4 -> Game ImmRenderState ()
 immSetColour colour = do
-  state <- getGameState
-  gameIO $ setUniform (Vec4Uniform "Colour" colour) (shader state)
+  state <- get
+  liftIO $ setUniform (Vec4Uniform "Colour" colour) (shader state)
 
 immSetModelMatrix :: Matrix4 -> Game ImmRenderState ()
 immSetModelMatrix model = do
-  state <- getGameState
-  gameIO $ setUniform (Mat4Uniform "Model" model) (shader state)
+  state <- get
+  liftIO $ setUniform (Mat4Uniform "Model" model) (shader state)
 
 immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState ()
 immSetViewProjectionMatrix viewProjection = do
-  state <- getGameState
-  gameIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state)
+  state <- get
+  liftIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state)
 
 -- Private
 
@@ -157,7 +157,7 @@ pushMatrix matrix state = state {
 
 loadMatrixStack :: Game ImmRenderState ()
 loadMatrixStack = do
-  state <- getGameState
+  state <- get
   immSetModelMatrix (head $ matrixStack state)
 
 to3d :: Vector2 -> Vector3
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index f4cddf8..5168cf2 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -44,7 +44,7 @@ data StaticModelResource = StaticModelResource
     material  :: Material,

     texture   :: Texture,

     boxes     :: V.Vector Box,

-    rkey      :: Resource

+    rkey      :: ReleaseKey

   }

 

 instance Eq StaticModelResource where

@@ -74,12 +74,12 @@ staticModelResource ::
   Model ->

   Game s StaticModelResource

 staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do

-  RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model

+  RenderModel elements _ numVertices <- liftIO . renderModelFromModel $ model

   elementBuf <- newBuffer

   vao <- newVAO

-  boxes <- gameIO $ modelBoxes model

+  boxes <- liftIO $ modelBoxes model

 

-  gameIO $ do

+  liftIO $ do

     let elemSize = 32::CUInt

         elemSize' = fromIntegral elemSize

         n = numVertices

@@ -98,9 +98,8 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t
     enableVAOAttrib texChan

 

   rkey <- register $ do

-    putStrLn "Releasing static model resource"

-    release' vao

-    release' elementBuf

+    release $ vaoKey vao

+    release $ bufferKey elementBuf

 

   return $

     StaticModelResource

diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 3cd89f3..4bbbde0 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -43,7 +43,7 @@ type Loader = Game SceneResources
 -- | Load the scene specified by the given file.

 loadScene :: FilePath -> Game s (SceneResources, SceneGraph)

 loadScene file = do

-  result <- gameIO $ loadSceneGraphFromFile file

+  result <- liftIO $ loadSceneGraphFromFile file

   case result of

     Left err -> gameError $ show err

     Right g -> case validate g of

@@ -85,9 +85,9 @@ loadResource key field modifyResources load = do
   case M.lookup key $ field sceneData of

     Just val -> return val

     Nothing -> do

-      gameIO $ printf "Loading %s..." key

+      liftIO $ printf "Loading %s..." key

       resource <- load

-      gameIO $ printf "done\n"

+      liftIO $ printf "done\n"

       modifyResources key resource

       return resource

 

@@ -139,9 +139,9 @@ newModel (SceneLeaf _ props) = do
   let rotation = asRotation $ value "rotation" props

       scale = asVec3 $ value "scale" props

 

-  gameIO $ printf "Loading model %s..." name

+  liftIO $ printf "Loading model %s..." name

   model <- loadModel' file rotation scale

-  gameIO . putStrLn $ "done"

+  liftIO . putStrLn $ "done"

   texture <- loadTexture tex

   sceneRes <- get

 

@@ -180,7 +180,7 @@ loadModel' file rotation scale = do
                   \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')

             )

 

-  (fmap transform $ Model.loadModel file) >>= gameIO . toGround

+  (fmap transform $ Model.loadModel file) >>= liftIO . toGround

 

 rotateModel :: Rotation -> Model -> Model

 rotateModel (Rotation ax ay az order) model =

@@ -213,7 +213,7 @@ newShaderProgram (SceneLeaf _ props) = do
   stype <- asString $ mandatory' "type" props

   prog <- GL.newProgram [vertShader, fragShader]

 

-  let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name

+  let getUniformLoc name = (liftIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name

 

   case stype of

     "static" -> do

diff --git a/Spear/Window.hs b/Spear/Window.hs
index 2dcd1fa..75a38f7 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -208,7 +208,7 @@ whenKeyUp = whenKeyInState GLFW.KeyState'Released
 
 whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s () -> Game s ()
 whenKeyInState state window key game = do
-  isDown <- fmap (==state) $ gameIO . GLFW.getKey window . toGLFWkey $ key
+  isDown <- fmap (==state) $ liftIO . GLFW.getKey window . toGLFWkey $ key
   when isDown game
 
 -- | Check whether the given keys are pressed and return the value associated
@@ -219,7 +219,7 @@ processKeys window = foldM f []
     f acc (key, result) = do
       isDown <-
         fmap (== GLFW.KeyState'Pressed) $
-          gameIO . GLFW.getKey (glfwWindow window) . toGLFWkey $
+          liftIO . GLFW.getKey (glfwWindow window) . toGLFWkey $
             key
       return $ if isDown then result : acc else acc
 
@@ -231,7 +231,7 @@ processButtons window = foldM f []
     f acc (button, result) = do
       isDown <-
         fmap (== GLFW.MouseButtonState'Pressed) $
-          gameIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $
+          liftIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $
             button
       return $ if isDown then result : acc else acc