Streamling the Game monad, use MonadIO for automatic lifting.

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 =