From 8f2ec33e8c15e523b2b60d3bfd8e6360313a0657 Mon Sep 17 00:00:00 2001
From: 3gg <3gg@shellblade.net>
Date: Sat, 17 Sep 2022 17:46:27 -0700
Subject: 2020s update

---
 .gitignore                    |   1 +
 Spear.cabal                   |  32 +-
 Spear/GL.hs                   | 827 +++++++++++++++++++++++-------------------
 Spear/Game.hs                 | 111 +++---
 Spear/Render/AnimatedModel.hs | 287 ++++++++-------
 Spear/Render/StaticModel.hs   | 146 ++++----
 Spear/Scene/Loader.hs         | 457 +++++++++++------------
 Spear/Step.hs                 | 201 +++++-----
 Spear/Sys/Timer.hsc           |  52 +--
 Spear/Window.hs               | 710 +++++++++++++++++++-----------------
 demos/pong/Main.hs            |  99 ++---
 demos/pong/Pong.hs            | 125 +++----
 demos/pong/Setup.hs           |   1 +
 demos/pong/cabal.project      |   2 +
 demos/pong/pong.cabal         |  12 +-
 15 files changed, 1635 insertions(+), 1428 deletions(-)
 create mode 100644 demos/pong/cabal.project

diff --git a/.gitignore b/.gitignore
index 8d5c25e..726ea43 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
 demos/pong/dist/
 demos/pong/pong
 dist/
+dist-newstyle/
diff --git a/Spear.cabal b/Spear.cabal
index a19d89f..4c75dd8 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -4,7 +4,7 @@ cabal-version: >=1.2
 build-type: Simple
 license: BSD3
 license-file: LICENSE
-maintainer: jeannekamikaze@gmail.com
+maintainer: 3gg@shellblade.net
 homepage: http://spear.shellblade.net
 synopsis: A 2.5D game framework.
 category: Game
@@ -12,13 +12,14 @@ author: Marc Sunet
 data-dir: ""
 
 library
-    build-depends: GLFW -any,
-                   OpenGL -any,
+    build-depends: GLFW-b -any,
+                   OpenGL >= 3,
                    OpenGLRaw -any,
                    StateVar -any,
                    base -any,
                    bytestring -any,
                    directory -any,
+                   exceptions -any,
                    mtl -any,
                    transformers -any,
                    resourcet -any,
@@ -46,6 +47,7 @@ library
                      Spear.Math.Segment
                      Spear.Math.Spatial2
                      Spear.Math.Spatial3
+                     Spear.Math.Sphere
                      Spear.Math.Triangle
                      Spear.Math.Utils
                      Spear.Math.Vector
@@ -87,18 +89,28 @@ library
     extensions: TypeFamilies
 
     includes: Spear/Assets/Image/BMP/BMP_load.h
-              Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h
-              Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h
-              Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h
-              Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h
-              Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h
+              Spear/Assets/Image/Image.h
+              Spear/Assets/Image/Image_error_code.h
+              Spear/Assets/Image/sys_types.h
+              Spear/Assets/Model/MD2/MD2_load.h
+              Spear/Assets/Model/OBJ/OBJ_load.h
+              Spear/Assets/Model/OBJ/cvector.h
+              Spear/Assets/Model/Model.h
+              Spear/Assets/Model/Model_error_code.h
+              Spear/Assets/Model/sys_types.h
+              Spear/Render/RenderModel.h
               Timer/Timer.h
 
-    include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render
+    include-dirs: .
+                  Spear
+                  Spear/Assets/Image
+                  Spear/Assets/Image/BMP
+                  Spear/Assets/Model
+                  Spear/Render
                   Spear/Sys
 
     hs-source-dirs: .
 
     ghc-options: -O2
 
-    ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs
+    ghc-prof-options: -O2 -fprof-auto -fprof-cafs
diff --git a/Spear/GL.hs b/Spear/GL.hs
index f5cfe4e..21ed9ec 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -1,101 +1,112 @@
 {-# LANGUAGE FlexibleInstances #-}
+
 module Spear.GL
-(
-    -- * Programs
-    GLSLProgram
-,   newProgram
-,   linkProgram
-,   useProgram
-,   unuseProgram
-,   withGLSLProgram
+  ( -- * Programs
+    GLSLProgram,
+    newProgram,
+    linkProgram,
+    useProgram,
+    unuseProgram,
+    withGLSLProgram,
+
     -- ** Locations
-,   attribLocation
-,   fragLocation
-,   uniformLocation
+    attribLocation,
+    fragLocation,
+    uniformLocation,
+
     -- ** Uniforms
-,   Uniform(..)
+    Uniform (..),
+
     -- * Shaders
-,   GLSLShader
-,   ShaderType(..)
-,   attachShader
-,   detachShader
-,   loadShader
-,   newShader
+    GLSLShader,
+    ShaderType (..),
+    attachShader,
+    detachShader,
+    loadShader,
+    newShader,
+
     -- ** Source loading
-,   loadSource
-,   shaderSource
-,   readSource
-,   compile
+    loadSource,
+    shaderSource,
+    readSource,
+    compile,
+
     -- * Helper functions
-,   ($=)
-,   Data.StateVar.get
+    ($=),
+    Data.StateVar.get,
+
     -- * VAOs
-,   VAO
-,   newVAO
-,   bindVAO
-,   unbindVAO
-,   enableVAOAttrib
-,   attribVAOPointer
+    VAO,
+    newVAO,
+    bindVAO,
+    unbindVAO,
+    enableVAOAttrib,
+    attribVAOPointer,
+
     -- ** Rendering
-,   drawArrays
-,   drawElements
+    drawArrays,
+    drawElements,
+
     -- * Buffers
-,   GLBuffer
-,   TargetBuffer(..)
-,   BufferUsage(..)
-,   newBuffer
-,   bindBuffer
-,   unbindBuffer
-,   BufferData(..)
-,   bufferData'
-,   withGLBuffer
+    GLBuffer,
+    TargetBuffer (..),
+    BufferUsage (..),
+    newBuffer,
+    bindBuffer,
+    unbindBuffer,
+    BufferData (..),
+    bufferData',
+    withGLBuffer,
+
     -- * Textures
-,   Texture
-,   SettableStateVar
-,   ($)
+    Texture,
+    SettableStateVar,
+    ($),
+
     -- ** Creation and destruction
-,   newTexture
-,   loadTextureImage
+    newTexture,
+    loadTextureImage,
+
     -- ** Manipulation
-,   bindTexture
-,   unbindTexture
-,   loadTextureData
-,   texParami
-,   texParamf
-,   activeTexture
+    bindTexture,
+    unbindTexture,
+    loadTextureData,
+    texParami,
+    texParamf,
+    activeTexture,
+
     -- * Error Handling
-,   getGLError
-,   printGLError
-,   assertGL
+    getGLError,
+    printGLError,
+    assertGL,
+
     -- * OpenGL
-,   module Graphics.Rendering.OpenGL.Raw.Core32
-,   Ptr
-,   nullPtr
-)
+    module Graphics.GL.Core46,
+    Ptr,
+    nullPtr,
+  )
 where
 
-import Spear.Assets.Image
-import Spear.Game
-import Spear.Math.Matrix3 (Matrix3)
-import Spear.Math.Matrix4 (Matrix4)
-import Spear.Math.Vector
-
 import Control.Monad
 import Control.Monad.Trans.Class
-import Control.Monad.Trans.Error
 import Control.Monad.Trans.State as State
 import qualified Data.ByteString.Char8 as B
 import Data.StateVar
 import Data.Word
 import Foreign.C.String
 import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.Storable
-import Foreign.Marshal.Utils as Foreign (with)
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.Marshal.Array (withArray)
+import Foreign.Marshal.Utils as Foreign (with)
+import Foreign.Ptr
+import Foreign.Storable
 import Foreign.Storable (peek)
-import Graphics.Rendering.OpenGL.Raw.Core32
+import Graphics.GL.Core46
+import Spear.Assets.Image
+import Spear.Game
+import Spear.Math.Matrix3 (Matrix3)
+import Spear.Math.Matrix4 (Matrix4)
+import Spear.Math.Vector
 import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
 import System.IO (hPutStrLn, stderr)
 import Unsafe.Coerce
@@ -105,30 +116,30 @@ import Unsafe.Coerce
 --
 
 -- | A GLSL shader handle.
-data GLSLShader  = GLSLShader
-    { getShader    :: GLuint
-    , getShaderKey :: Resource
-    }
+data GLSLShader = GLSLShader
+  { getShader :: GLuint,
+    getShaderKey :: Resource
+  }
 
 instance ResourceClass GLSLShader where
-         getResource = getShaderKey
+  getResource = getShaderKey
 
 -- | A GLSL program handle.
 data GLSLProgram = GLSLProgram
-    { getProgram    :: GLuint
-    , getProgramKey :: Resource
-    }
+  { getProgram :: GLuint,
+    getProgramKey :: Resource
+  }
 
 instance ResourceClass GLSLProgram where
-         getResource = getProgramKey
+  getResource = getProgramKey
 
 -- | Supported shader types.
 data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show)
 
 toGLShader :: ShaderType -> GLenum
-toGLShader VertexShader   = gl_VERTEX_SHADER
-toGLShader FragmentShader = gl_FRAGMENT_SHADER
-toGLShader GeometryShader = gl_GEOMETRY_SHADER
+toGLShader VertexShader = GL_VERTEX_SHADER
+toGLShader FragmentShader = GL_FRAGMENT_SHADER
+toGLShader GeometryShader = GL_GEOMETRY_SHADER
 
 -- | Apply the given function to the program's id.
 withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
@@ -137,58 +148,58 @@ withGLSLProgram prog f = f $ getProgram prog
 -- | Get the location of the given uniform variable within the given program.
 uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
 uniformLocation prog var = makeGettableStateVar $
-    withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
+  withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
 
 -- | Get or set the location of the given variable to a fragment shader colour number.
 fragLocation :: GLSLProgram -> String -> StateVar GLint
 fragLocation prog var = makeStateVar get set
-    where
-        get     = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
-        set idx = withCString var $ \str ->
-            glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
+  where
+    get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
+    set idx = withCString var $ \str ->
+      glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
 
 -- | Get or set the location of the given attribute within the given program.
 attribLocation :: GLSLProgram -> String -> StateVar GLint
 attribLocation prog var = makeStateVar get set
-    where
-        get     = withCString var $ \str -> glGetAttribLocation  (getProgram prog) (unsafeCoerce str)
-        set idx = withCString var $ \str ->
-            glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
+  where
+    get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str)
+    set idx = withCString var $ \str ->
+      glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
 
 -- | Create a new program.
 newProgram :: [GLSLShader] -> Game s GLSLProgram
 newProgram shaders = do
-    h <- gameIO glCreateProgram
-    when (h == 0) $ gameError "glCreateProgram failed"
-    rkey <- register $ deleteProgram h
-    let program = GLSLProgram h rkey
-    mapM_ (gameIO . attachShader program) shaders
-    linkProgram program
-    return program
+  h <- gameIO glCreateProgram
+  when (h == 0) $ gameError "glCreateProgram failed"
+  rkey <- register $ deleteProgram h
+  let program = GLSLProgram h rkey
+  mapM_ (gameIO . attachShader program) shaders
+  linkProgram program
+  return program
 
 --  Delete the program.
 deleteProgram :: GLuint -> IO ()
 --deleteProgram = glDeleteProgram
 deleteProgram prog = do
-    putStrLn $ "Deleting shader program " ++ show prog
-    glDeleteProgram prog
+  putStrLn $ "Deleting shader program " ++ show prog
+  glDeleteProgram prog
 
 -- | Link the program.
 linkProgram :: GLSLProgram -> Game s ()
 linkProgram prog = do
-    let h = getProgram prog
-    err <- gameIO $ do
-        glLinkProgram h
-        alloca $ \statptr -> do
-            glGetProgramiv h gl_LINK_STATUS statptr
-            status <- peek statptr
-            case status of
-                0 -> getStatus glGetProgramiv glGetProgramInfoLog h
-                _ -> return ""
-
-    case length err of
-        0 -> return ()
-        _ -> gameError err
+  let h = getProgram prog
+  err <- gameIO $ do
+    glLinkProgram h
+    alloca $ \statptr -> do
+      glGetProgramiv h GL_LINK_STATUS statptr
+      status <- peek statptr
+      case status of
+        0 -> getStatus glGetProgramiv glGetProgramInfoLog h
+        _ -> return ""
+
+  case length err of
+    0 -> return ()
+    _ -> gameError err
 
 -- | Use the program.
 useProgram :: GLSLProgram -> IO ()
@@ -212,82 +223,84 @@ detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
 -- see 'loadSource', 'shaderSource' and 'readSource'.
 loadShader :: ShaderType -> FilePath -> Game s GLSLShader
 loadShader shaderType file = do
-    shader <- newShader shaderType
-    loadSource file shader
-    compile file shader
-    return shader
+  shader <- newShader shaderType
+  loadSource file shader
+  compile file shader
+  return shader
 
 -- | Create a new shader.
 newShader :: ShaderType -> Game s GLSLShader
 newShader shaderType = do
-    h <- gameIO $ glCreateShader (toGLShader shaderType)
-    case h of
-        0 -> gameError "glCreateShader failed"
-        _ -> do
-            rkey <- register $ deleteShader h
-            return $ GLSLShader h rkey
+  h <- gameIO $ glCreateShader (toGLShader shaderType)
+  case h of
+    0 -> gameError "glCreateShader failed"
+    _ -> do
+      rkey <- register $ deleteShader h
+      return $ GLSLShader h rkey
 
 -- | Free the shader.
 deleteShader :: GLuint -> IO ()
 --deleteShader = glDeleteShader
 deleteShader shader = do
-    putStrLn $ "Deleting shader " ++ show shader
-    glDeleteShader shader
+  putStrLn $ "Deleting shader " ++ show shader
+  glDeleteShader shader
 
 -- | Load a shader source from the file specified by the given string
 -- into the shader.
 loadSource :: FilePath -> GLSLShader -> Game s ()
 loadSource file h = do
-    exists <- gameIO $ doesFileExist file
-    case exists of
-        False -> gameError "the specified shader file does not exist"
-        True  -> gameIO $ do
-            code <- readSource file
-            withCString code $ shaderSource h
+  exists <- gameIO $ doesFileExist file
+  case exists of
+    False -> gameError "the specified shader file does not exist"
+    True -> gameIO $ do
+      code <- readSource file
+      withCString code $ shaderSource h
 
 -- | Load the given shader source into the shader.
 shaderSource :: GLSLShader -> CString -> IO ()
 shaderSource shader str =
-    let ptr = unsafeCoerce str
-    in  withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
+  let ptr = unsafeCoerce str
+   in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
 
 -- | Compile the shader.
 compile :: FilePath -> GLSLShader -> Game s ()
 compile file shader = do
-    let h = getShader shader
+  let h = getShader shader
 
-    -- Compile
-    gameIO $ glCompileShader h
+  -- Compile
+  gameIO $ glCompileShader h
 
-    -- Verify status
-    err <- gameIO $ alloca $ \statusPtr -> do
-        glGetShaderiv h gl_COMPILE_STATUS statusPtr
-        result <- peek statusPtr
-        case result of
-            0 -> getStatus glGetShaderiv glGetShaderInfoLog h
-            _ -> return ""
+  -- Verify status
+  err <- gameIO $
+    alloca $ \statusPtr -> do
+      glGetShaderiv h GL_COMPILE_STATUS statusPtr
+      result <- peek statusPtr
+      case result of
+        0 -> getStatus glGetShaderiv glGetShaderInfoLog h
+        _ -> return ""
 
-    case length err of
-        0 -> return ()
-        _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
+  case length err of
+    0 -> return ()
+    _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
 
 type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
-type LogCall    = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
+
+type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
 
 getStatus :: StatusCall -> LogCall -> GLuint -> IO String
 getStatus getStatus getLog h = do
-    alloca $ \lenPtr -> do
-        getStatus h gl_INFO_LOG_LENGTH lenPtr
-        len <- peek lenPtr
-        case len of
-            0 -> return ""
-            _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
+  alloca $ \lenPtr -> do
+    getStatus h GL_INFO_LOG_LENGTH lenPtr
+    len <- peek lenPtr
+    case len of
+      0 -> return ""
+      _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
 
 getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
 getErrorString getLog h len str = do
-    let ptr = unsafeCoerce str
-    getLog h len nullPtr ptr
-    peekCString str
+  let ptr = unsafeCoerce str
+  getLog h len nullPtr ptr
+  peekCString str
 
 -- | Load the shader source specified by the given file.
 --
@@ -298,110 +311,121 @@ readSource = fmap B.unpack . readSource'
 
 readSource' :: FilePath -> IO B.ByteString
 readSource' file = do
-    let includeB      = B.pack "#include"
-        newLineB      = B.pack "\n"
-        isInclude     = ((==) includeB) . B.take 8
-        clean         = B.dropWhile (\c -> c == ' ')
-        cleanInclude  = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
-        toLines       = B.splitWith (\c -> c == '\n' || c == '\r')
-        addNewLine s  = if (B.last s /= '\n') then B.append s newLineB else s
-        parse         = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence .
-                        fmap (processLine . clean) . toLines
-        processLine l =
-            if isInclude l
-            then readSource' $ B.unpack . clean . cleanInclude $ l
-            else return l
-
-    contents <- B.readFile file
-
-    dir <- getCurrentDirectory
-    let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
-
-    setCurrentDirectory dir'
-    code <- parse contents
-    setCurrentDirectory dir
-
-    return code
+  let includeB = B.pack "#include"
+      newLineB = B.pack "\n"
+      isInclude = ((==) includeB) . B.take 8
+      clean = B.dropWhile (\c -> c == ' ')
+      cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
+      toLines = B.splitWith (\c -> c == '\n' || c == '\r')
+      addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s
+      parse =
+        fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence
+          . fmap (processLine . clean)
+          . toLines
+      processLine l =
+        if isInclude l
+          then readSource' $ B.unpack . clean . cleanInclude $ l
+          else return l
+
+  contents <- B.readFile file
+
+  dir <- getCurrentDirectory
+  let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
+
+  setCurrentDirectory dir'
+  code <- parse contents
+  setCurrentDirectory dir
+
+  return code
 
 class Uniform a where
-      -- | Load a list of uniform values.
-      uniform :: GLint -> a -> IO ()
+  -- | Load a list of uniform values.
+  uniform :: GLint -> a -> IO ()
 
 instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a)
-instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a)
-instance Uniform CFloat where uniform loc a = glUniform1f loc a
 
-instance Uniform (Int,Int) where
-         uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
+instance Uniform Float where uniform loc a = glUniform1f loc a
 
-instance Uniform (Float,Float) where
-         uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y)
+instance Uniform CFloat where uniform loc a = glUniform1f loc (unsafeCoerce a)
 
-instance Uniform (Int,Int,Int) where
-         uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z)
+instance Uniform (Int, Int) where
+  uniform loc (x, y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
 
-instance Uniform (Float,Float,Float) where
-         uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z)
+instance Uniform (Float, Float) where
+  uniform loc (x, y) = glUniform2f loc x y
 
-instance Uniform (Int,Int,Int,Int) where
-         uniform loc (x,y,z,w) = glUniform4i loc
-                 (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w)
+instance Uniform (Int, Int, Int) where
+  uniform loc (x, y, z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z)
 
-instance Uniform (Float,Float,Float,Float) where
-         uniform loc (x,y,z,w) = glUniform4f loc
-                 (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w)
+instance Uniform (Float, Float, Float) where
+  uniform loc (x, y, z) = glUniform3f loc x y z
+
+instance Uniform (Int, Int, Int, Int) where
+  uniform loc (x, y, z, w) =
+    glUniform4i
+      loc
+      (fromIntegral x)
+      (fromIntegral y)
+      (fromIntegral z)
+      (fromIntegral w)
+
+instance Uniform (Float, Float, Float, Float) where
+  uniform loc (x, y, z, w) = glUniform4f loc x y z w
 
 instance Uniform Vector2 where
-         uniform loc v = glUniform2f loc x' y'
-                 where x' = unsafeCoerce $ x v
-                       y' = unsafeCoerce $ y v
+  uniform loc v = glUniform2f loc x' y'
+    where
+      x' = unsafeCoerce $ x v
+      y' = unsafeCoerce $ y v
 
 instance Uniform Vector3 where
-         uniform loc v = glUniform3f loc x' y' z'
-                 where x' = unsafeCoerce $ x v
-                       y' = unsafeCoerce $ y v
-                       z' = unsafeCoerce $ z v
+  uniform loc v = glUniform3f loc x' y' z'
+    where
+      x' = unsafeCoerce $ x v
+      y' = unsafeCoerce $ y v
+      z' = unsafeCoerce $ z v
 
 instance Uniform Vector4 where
-         uniform loc v = glUniform4f loc x' y' z' w'
-                 where x' = unsafeCoerce $ x v
-                       y' = unsafeCoerce $ y v
-                       z' = unsafeCoerce $ z v
-                       w' = unsafeCoerce $ w v
+  uniform loc v = glUniform4f loc x' y' z' w'
+    where
+      x' = unsafeCoerce $ x v
+      y' = unsafeCoerce $ y v
+      z' = unsafeCoerce $ z v
+      w' = unsafeCoerce $ w v
 
 instance Uniform Matrix3 where
-         uniform loc mat =
-                 with mat $ \ptrMat ->
-                 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
+  uniform loc mat =
+    with mat $ \ptrMat ->
+      glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
 
 instance Uniform Matrix4 where
-         uniform loc mat =
-                 with mat $ \ptrMat ->
-                 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
+  uniform loc mat =
+    with mat $ \ptrMat ->
+      glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
 
 instance Uniform [Float] where
-         uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr ->
-                 case length vals of
-                      1 -> glUniform1fv loc 1 ptr
-                      2 -> glUniform2fv loc 1 ptr
-                      3 -> glUniform3fv loc 1 ptr
-                      4 -> glUniform4fv loc 1 ptr
+  uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr ->
+    case length vals of
+      1 -> glUniform1fv loc 1 ptr
+      2 -> glUniform2fv loc 1 ptr
+      3 -> glUniform3fv loc 1 ptr
+      4 -> glUniform4fv loc 1 ptr
 
 instance Uniform [CFloat] where
-         uniform loc vals = withArray vals $ \ptr ->
-                 case length vals of
-                      1 -> glUniform1fv loc 1 ptr
-                      2 -> glUniform2fv loc 1 ptr
-                      3 -> glUniform3fv loc 1 ptr
-                      4 -> glUniform4fv loc 1 ptr
+  uniform loc vals = withArray vals $ \ptr ->
+    case length vals of
+      1 -> glUniform1fv loc 1 $ castPtr ptr
+      2 -> glUniform2fv loc 1 $ castPtr ptr
+      3 -> glUniform3fv loc 1 $ castPtr ptr
+      4 -> glUniform4fv loc 1 $ castPtr ptr
 
 instance Uniform [Int] where
-         uniform loc vals = withArray (map fromIntegral vals) $ \ptr ->
-                 case length vals of
-                      1 -> glUniform1iv loc 1 ptr
-                      2 -> glUniform2iv loc 1 ptr
-                      3 -> glUniform3iv loc 1 ptr
-                      4 -> glUniform4iv loc 1 ptr
+  uniform loc vals = withArray (map fromIntegral vals) $ \ptr ->
+    case length vals of
+      1 -> glUniform1iv loc 1 ptr
+      2 -> glUniform2iv loc 1 ptr
+      3 -> glUniform3iv loc 1 ptr
+      4 -> glUniform4iv loc 1 ptr
 
 --
 -- VAOs
@@ -409,28 +433,29 @@ instance Uniform [Int] where
 
 -- | A vertex array object.
 data VAO = VAO
-    { getVAO :: GLuint
-    , vaoKey :: Resource
-    }
+  { getVAO :: GLuint,
+    vaoKey :: Resource
+  }
 
 instance ResourceClass VAO where
-         getResource = vaoKey
+  getResource = vaoKey
 
 instance Eq VAO where
-    vao1 == vao2 = getVAO vao1 == getVAO vao2
+  vao1 == vao2 = getVAO vao1 == getVAO vao2
 
 instance Ord VAO where
-    vao1 < vao2 = getVAO vao1 < getVAO vao2
+  vao1 < vao2 = getVAO vao1 < getVAO vao2
+  vao1 <= vao2 = getVAO vao1 <= getVAO vao2
 
 -- | Create a new vao.
 newVAO :: Game s VAO
 newVAO = do
-    h <- gameIO . alloca $ \ptr -> do
-        glGenVertexArrays 1 ptr
-        peek ptr
+  h <- gameIO . alloca $ \ptr -> do
+    glGenVertexArrays 1 ptr
+    peek ptr
 
-    rkey <- register $ deleteVAO h
-    return $ VAO h rkey
+  rkey <- register $ deleteVAO h
+  return $ VAO h rkey
 
 -- | Delete the vao.
 deleteVAO :: GLuint -> IO ()
@@ -447,38 +472,54 @@ unbindVAO = glBindVertexArray 0
 -- | Enable the given vertex attribute of the bound vao.
 --
 -- See also 'bindVAO'.
-enableVAOAttrib :: GLuint -- ^ Attribute index.
-                -> IO ()
+enableVAOAttrib ::
+  -- | Attribute index.
+  GLuint ->
+  IO ()
 enableVAOAttrib = glEnableVertexAttribArray
 
 -- | Bind the bound buffer to the given point.
-attribVAOPointer
-    :: GLuint  -- ^ The index of the generic vertex attribute to be modified.
-    -> GLint   -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4.
-    -> GLenum  -- ^ The data type of each component in the array.
-    -> Bool    -- ^ Whether fixed-point data values should be normalized.
-    -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes.
-    -> Int     -- ^ Offset to the first component in the array.
-    -> IO ()
+attribVAOPointer ::
+  -- | The index of the generic vertex attribute to be modified.
+  GLuint ->
+  -- | The number of components per generic vertex attribute. Must be 1,2,3,4.
+  GLint ->
+  -- | The data type of each component in the array.
+  GLenum ->
+  -- | Whether fixed-point data values should be normalized.
+  Bool ->
+  -- | Stride. Byte offset between consecutive generic vertex attributes.
+  GLsizei ->
+  -- | Offset to the first component in the array.
+  Int ->
+  IO ()
 attribVAOPointer idx ncomp dattype normalise stride off =
-    glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off)
-                          where normalise' = if normalise then 1 else 0
+  glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off)
+  where
+    normalise' = if normalise then 1 else 0
 
 -- | Draw the bound vao.
-drawArrays
-    :: GLenum -- ^ The kind of primitives to render.
-    -> Int    -- ^ Starting index in the enabled arrays.
-    -> Int    -- ^ The number of indices to be rendered.
-    -> IO ()
+drawArrays ::
+  -- | The kind of primitives to render.
+  GLenum ->
+  -- | Starting index in the enabled arrays.
+  Int ->
+  -- | The number of indices to be rendered.
+  Int ->
+  IO ()
 drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
 
 -- | Draw the bound vao, indexed mode.
-drawElements
-    :: GLenum -- ^ The kind of primitives to render.
-    -> Int    -- ^ The number of elements to be rendered.
-    -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT.
-    -> Ptr a  -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer.
-    -> IO ()
+drawElements ::
+  -- | The kind of primitives to render.
+  GLenum ->
+  -- | The number of elements to be rendered.
+  Int ->
+  -- | The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT.
+  GLenum ->
+  -- | Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer.
+  Ptr a ->
+  IO ()
 drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
 
 --
@@ -487,60 +528,60 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
 
 -- | An OpenGL buffer.
 data GLBuffer = GLBuffer
-    { getBuffer :: GLuint
-    , rkey      :: Resource
-    }
+  { getBuffer :: GLuint,
+    rkey :: Resource
+  }
 
 instance ResourceClass GLBuffer where
-         getResource = rkey
+  getResource = rkey
 
 -- | The type of target buffer.
 data TargetBuffer
-    = ArrayBuffer
-    | ElementArrayBuffer
-    | PixelPackBuffer
-    | PixelUnpackBuffer
-    deriving (Eq, Show)
+  = ArrayBuffer
+  | ElementArrayBuffer
+  | PixelPackBuffer
+  | PixelUnpackBuffer
+  deriving (Eq, Show)
 
 fromTarget :: TargetBuffer -> GLenum
-fromTarget ArrayBuffer        = gl_ARRAY_BUFFER
-fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
-fromTarget PixelPackBuffer    = gl_PIXEL_PACK_BUFFER
-fromTarget PixelUnpackBuffer  = gl_PIXEL_UNPACK_BUFFER
+fromTarget ArrayBuffer = GL_ARRAY_BUFFER
+fromTarget ElementArrayBuffer = GL_ELEMENT_ARRAY_BUFFER
+fromTarget PixelPackBuffer = GL_PIXEL_PACK_BUFFER
+fromTarget PixelUnpackBuffer = GL_PIXEL_UNPACK_BUFFER
 
 -- | A buffer usage.
 data BufferUsage
-    = StreamDraw
-    | StreamRead
-    | StreamCopy
-    | StaticDraw
-    | StaticRead
-    | StaticCopy
-    | DynamicDraw
-    | DynamicRead
-    | DynamicCopy
-    deriving (Eq, Show)
+  = StreamDraw
+  | StreamRead
+  | StreamCopy
+  | StaticDraw
+  | StaticRead
+  | StaticCopy
+  | DynamicDraw
+  | DynamicRead
+  | DynamicCopy
+  deriving (Eq, Show)
 
 fromUsage :: BufferUsage -> GLenum
-fromUsage StreamDraw  = gl_STREAM_DRAW
-fromUsage StreamRead  = gl_STREAM_READ
-fromUsage StreamCopy  = gl_STREAM_COPY
-fromUsage StaticDraw  = gl_STATIC_DRAW
-fromUsage StaticRead  = gl_STATIC_READ
-fromUsage StaticCopy  = gl_STATIC_COPY
-fromUsage DynamicDraw = gl_DYNAMIC_DRAW
-fromUsage DynamicRead = gl_DYNAMIC_READ
-fromUsage DynamicCopy = gl_DYNAMIC_COPY
+fromUsage StreamDraw = GL_STREAM_DRAW
+fromUsage StreamRead = GL_STREAM_READ
+fromUsage StreamCopy = GL_STREAM_COPY
+fromUsage StaticDraw = GL_STATIC_DRAW
+fromUsage StaticRead = GL_STATIC_READ
+fromUsage StaticCopy = GL_STATIC_COPY
+fromUsage DynamicDraw = GL_DYNAMIC_DRAW
+fromUsage DynamicRead = GL_DYNAMIC_READ
+fromUsage DynamicCopy = GL_DYNAMIC_COPY
 
 -- | Create a new buffer.
 newBuffer :: Game s GLBuffer
 newBuffer = do
-    h <- gameIO . alloca $ \ptr -> do
-        glGenBuffers 1 ptr
-        peek ptr
+  h <- gameIO . alloca $ \ptr -> do
+    glGenBuffers 1 ptr
+    peek ptr
 
-    rkey <- register $ deleteBuffer h
-    return $ GLBuffer h rkey
+  rkey <- register $ deleteBuffer h
+  return $ GLBuffer h rkey
 
 -- | Delete the buffer.
 deleteBuffer :: GLuint -> IO ()
@@ -555,21 +596,30 @@ unbindBuffer :: TargetBuffer -> IO ()
 unbindBuffer target = glBindBuffer (fromTarget target) 0
 
 class Storable a => BufferData a where
-      -- | Set the buffer's data.
-      bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
-      bufferData tgt vals usage =
-                 let n = sizeOf (head vals) * length vals
-                 in withArray vals $ \ptr -> bufferData' tgt n ptr usage
+  -- | Set the buffer's data.
+  bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
+  bufferData tgt vals usage =
+    let n = sizeOf (head vals) * length vals
+     in withArray vals $ \ptr -> bufferData' tgt n ptr usage
 
 instance BufferData Word8
+
 instance BufferData Word16
+
 instance BufferData Word32
+
 instance BufferData CChar
+
 instance BufferData CInt
+
 instance BufferData CFloat
+
 instance BufferData CDouble
+
 instance BufferData Int
+
 instance BufferData Float
+
 instance BufferData Double
 
 {-bufferData :: Storable a
@@ -582,11 +632,13 @@ bufferData target n bufData usage = withArray bufData $
     \ptr -> bufferData target (n * length bufData) ptr usage-}
 
 -- | Set the buffer's data.
-bufferData' :: TargetBuffer
-            -> Int -- ^ Buffer size in bytes.
-            -> Ptr a
-            -> BufferUsage
-            -> IO ()
+bufferData' ::
+  TargetBuffer ->
+  -- | Buffer size in bytes.
+  Int ->
+  Ptr a ->
+  BufferUsage ->
+  IO ()
 bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
 
 -- | Apply the given function the buffer's id.
@@ -599,88 +651,102 @@ withGLBuffer buf f = f $ getBuffer buf
 
 -- | Represents a texture resource.
 data Texture = Texture
-    { getTex :: GLuint
-    , texKey :: Resource
-    }
+  { getTex :: GLuint,
+    texKey :: Resource
+  }
 
 instance Eq Texture where
-    t1 == t2 = getTex t1 == getTex t2
+  t1 == t2 = getTex t1 == getTex t2
 
 instance Ord Texture where
-    t1 < t2 = getTex t1 < getTex t2
+  t1 < t2 = getTex t1 < getTex t2
+  t1 <= t2 = getTex t1 <= getTex t2
 
 instance ResourceClass Texture where
-         getResource = texKey
+  getResource = texKey
 
 -- | Create a new texture.
 newTexture :: Game s Texture
 newTexture = do
-    tex <- gameIO . alloca $ \ptr -> do
-        glGenTextures 1 ptr
-        peek ptr
+  tex <- gameIO . alloca $ \ptr -> do
+    glGenTextures 1 ptr
+    peek ptr
 
-    rkey <- register $ deleteTexture tex
-    return $ Texture tex rkey
+  rkey <- register $ deleteTexture tex
+  return $ Texture tex rkey
 
 -- | Delete the texture.
 deleteTexture :: GLuint -> IO ()
 --deleteTexture tex = with tex $ glDeleteTextures 1
 deleteTexture tex = do
-    putStrLn $ "Releasing texture " ++ show tex
-    with tex $ glDeleteTextures 1
+  putStrLn $ "Releasing texture " ++ show tex
+  with tex $ glDeleteTextures 1
 
 -- | Load the 'Texture' specified by the given file.
-loadTextureImage :: FilePath
-                 -> GLenum          -- ^ Texture's min filter.
-                 -> GLenum          -- ^ Texture's mag filter.
-                 -> Game s Texture
+loadTextureImage ::
+  FilePath ->
+  -- | Texture's min filter.
+  GLenum ->
+  -- | Texture's mag filter.
+  GLenum ->
+  Game s Texture
 loadTextureImage file minFilter magFilter = do
-    image <- loadImage file
-    tex   <- newTexture
-    gameIO $ do
-        let w    = width  image
-            h    = height image
-            pix  = pixels image
-            rgb  = fromIntegral . fromEnum $ gl_RGB
+  image <- loadImage file
+  tex <- newTexture
+  gameIO $ do
+    let w = width image
+        h = height image
+        pix = pixels image
+        rgb = fromIntegral . fromEnum $ GL_RGB
 
-        bindTexture tex
-        loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix
-        texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter
-        texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter
+    bindTexture tex
+    loadTextureData GL_TEXTURE_2D 0 rgb w h 0 GL_RGB GL_UNSIGNED_BYTE pix
+    texParami GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $= minFilter
+    texParami GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $= magFilter
 
-    return tex
+  return tex
 
 -- | Bind the texture.
 bindTexture :: Texture -> IO ()
-bindTexture = glBindTexture gl_TEXTURE_2D . getTex
+bindTexture = glBindTexture GL_TEXTURE_2D . getTex
 
 -- | Unbind the bound texture.
 unbindTexture :: IO ()
-unbindTexture = glBindTexture gl_TEXTURE_2D 0
+unbindTexture = glBindTexture GL_TEXTURE_2D 0
 
 -- | Load data onto the bound texture.
 --
 -- See also 'bindTexture'.
-loadTextureData :: GLenum
-                -> Int -- ^ Target
-                -> Int -- ^ Level
-                -> Int -- ^ Internal format
-                -> Int -- ^ Width
-                -> Int -- ^ Height
-                -> GLenum -- ^ Border
-                -> GLenum -- ^ Texture type
-                -> Ptr a -- ^ Texture data
-                -> IO ()
+loadTextureData ::
+  GLenum ->
+  -- | Target
+  Int ->
+  -- | Level
+  Int ->
+  -- | Internal format
+  Int ->
+  -- | Width
+  Int ->
+  -- | Height
+  Int ->
+  -- | Border
+  GLenum ->
+  -- | Texture type
+  GLenum ->
+  -- | Texture data
+  Ptr a ->
+  IO ()
 loadTextureData target level internalFormat width height border format texType texData = do
-    glTexImage2D target
-                 (fromIntegral level)
-                 (fromIntegral internalFormat)
-                 (fromIntegral width)
-                 (fromIntegral height)
-                 (fromIntegral border)
-                 (fromIntegral format)
-                 texType
-                 texData
+  glTexImage2D
+    target
+    (fromIntegral level)
+    (fromIntegral internalFormat)
+    (fromIntegral width)
+    (fromIntegral height)
+    (fromIntegral border)
+    (fromIntegral format)
+    texType
+    texData
 
 -- | Set the bound texture's parameter to the given value.
 texParami :: GLenum -> GLenum -> SettableStateVar GLenum
@@ -701,19 +767,20 @@ activeTexture = makeSettableStateVar glActiveTexture
 -- | Get the last OpenGL error.
 getGLError :: IO (Maybe String)
 getGLError = fmap translate glGetError
-    where
-        translate err
-            | err == gl_NO_ERROR          = Nothing
-            | err == gl_INVALID_ENUM      = Just "Invalid enum"
-            | err == gl_INVALID_VALUE     = Just "Invalid value"
-            | err == gl_INVALID_OPERATION = Just "Invalid operation"
-            | err == gl_OUT_OF_MEMORY     = Just "Out of memory"
-            | otherwise                   = Just "Unknown error"
+  where
+    translate err
+      | err == GL_NO_ERROR = Nothing
+      | err == GL_INVALID_ENUM = Just "Invalid enum"
+      | err == GL_INVALID_VALUE = Just "Invalid value"
+      | err == GL_INVALID_OPERATION = Just "Invalid operation"
+      | err == GL_OUT_OF_MEMORY = Just "Out of memory"
+      | otherwise = Just "Unknown error"
 
 -- | Print the last OpenGL error.
 printGLError :: IO ()
-printGLError = getGLError >>= \err -> case err of
-    Nothing  -> return ()
+printGLError =
+  getGLError >>= \err -> case err of
+    Nothing -> return ()
     Just str -> hPutStrLn stderr str
 
 -- | Run the given setup action and check for OpenGL errors.
@@ -722,8 +789,8 @@ printGLError = getGLError >>= \err -> case err of
 -- the given string appended to the string describing the error.
 assertGL :: Game s a -> String -> Game s a
 assertGL action err = do
-    result <- action
-    status <- gameIO getGLError
-    case status of
-        Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str
-        Nothing  -> return result
+  result <- action
+  status <- gameIO 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 44cb13c..c5b043b 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -1,47 +1,56 @@
 module Spear.Game
-(
-    Game
-,   Resource
-,   ResourceClass(..)
+  ( Game,
+    GameException (..),
+    Resource,
+    ResourceClass (..),
+
     -- * Game state
-,   getGameState
-,   saveGameState
-,   modifyGameState
+    getGameState,
+    saveGameState,
+    modifyGameState,
+
     -- * Game resources
-,   register
-,   unregister
+    register,
+    unregister,
+
     -- * Error handling
-,   gameError
-,   assertMaybe
-,   catchGameError
-,   catchGameErrorFinally
+    gameError,
+    assertMaybe,
+    catchGameError,
+    catchGameErrorFinally,
+
     -- * Running and IO
-,   runGame
-,   runGame'
-,   runSubGame
-,   runSubGame'
-,   evalSubGame
-,   execSubGame
-,   gameIO
-)
+    runGame,
+    runGame',
+    runSubGame,
+    runSubGame',
+    evalSubGame,
+    execSubGame,
+    gameIO,
+  )
 where
 
-import Control.Monad.Trans.Class (lift)
+import Control.Monad.Catch
 import Control.Monad.State.Strict
-import Control.Monad.Error
+import Control.Monad.Trans.Class (lift)
 import qualified Control.Monad.Trans.Resource as R
 
 type Resource = R.ReleaseKey
-type Game s = StateT s (R.ResourceT (ErrorT String IO))
+
+type Game s = StateT s (R.ResourceT IO)
 
 class ResourceClass a where
-      getResource :: a -> Resource
+  getResource :: a -> Resource
+
+  release :: a -> Game s ()
+  release = unregister . getResource
+
+  clean :: a -> IO ()
+  clean = R.release . getResource
 
-      release :: a -> Game s ()
-      release = unregister . getResource
+newtype GameException = GameException String deriving (Show)
 
-      clean :: a -> IO ()
-      clean = R.release . getResource
+instance Exception GameException
 
 -- | Retrieve the game state.
 getGameState :: Game s s
@@ -65,49 +74,49 @@ unregister = lift . R.release
 
 -- | Throw an error from the 'Game' monad.
 gameError :: String -> Game s a
-gameError = lift . lift . throwError
+gameError = gameError' . GameException
+
+-- | Throw an error from the 'Game' monad.
+gameError' :: GameException -> Game s a
+gameError' = lift . lift . throwM
 
--- | Throw the given error string if given 'Nothing'.
-assertMaybe :: Maybe a -> String -> Game s a
-assertMaybe Nothing err = gameError err
-assertMaybe (Just x) _  = return x
+-- | Throw the given error if given 'Nothing'.
+assertMaybe :: Maybe a -> GameException -> Game s a
+assertMaybe Nothing err = gameError' err
+assertMaybe (Just x) _ = return x
 
 -- | Run the given game with the given error handler.
-catchGameError :: Game s a -> (String -> Game s a) -> Game s a
-catchGameError game catch = catchError game catch
+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 = catchError game $ \err -> finally >> gameError err
+catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err
 
 -- | Run the given game.
-runGame :: Game s a -> s -> IO (Either String (a,s))
-runGame game state = runErrorT . R.runResourceT . runStateT game $ state
+runGame :: Game s a -> s -> IO (a, s)
+runGame game = R.runResourceT . runStateT game
 
 -- | Run the given game and discard its state.
-runGame' :: Game s a -> s -> IO (Either String a)
-runGame' g s = runGame g s >>= \result -> return $ case result of
-         Right (a,s) -> Right a
-         Left err -> Left err
+runGame' :: Game s a -> s -> IO a
+runGame' g s = fst <$> runGame g s
 
 -- | Fully run the given sub game, unrolling the entire monad stack.
-runSubGame :: Game s a -> s -> Game t (a,s)
-runSubGame game state = gameIO (runGame game state) >>= \result -> case result of
-           Left err -> gameError err
-           Right x  -> return x
+runSubGame :: Game s a -> s -> Game t (a, s)
+runSubGame g s = gameIO $ runGame g s
 
 -- | Like 'runSubGame', but discarding the result.
 runSubGame' :: Game s a -> s -> Game t ()
-runSubGame' game state = runSubGame game state >> return ()
+runSubGame' g s = void $ runSubGame g s
 
 -- | Run the given game and return its result.
 evalSubGame :: Game s a -> s -> Game t a
-evalSubGame g s = runSubGame g s >>= \(a,_) -> return a
+evalSubGame g s = fst <$> runSubGame g s
 
 -- | Run the given game and return its state.
 execSubGame :: Game s a -> s -> Game t s
-execSubGame g s = runSubGame g s >>= \(_,s) -> return s
+execSubGame g s = snd <$> runSubGame g s
 
 -- | Perform the given IO action in the 'Game' monad.
 gameIO :: IO a -> Game s a
-gameIO = lift . lift . lift
+gameIO = lift . lift
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index c31c18a..e69ce75 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -1,35 +1,41 @@
 module Spear.Render.AnimatedModel
-(
-    -- * Data types
-    AnimatedModelResource
-,   AnimatedModelRenderer
-,   AnimationSpeed
+  ( -- * Data types
+    AnimatedModelResource,
+    AnimatedModelRenderer,
+    AnimationSpeed,
+
     -- * Construction and destruction
-,   animatedModelResource
-,   animatedModelRenderer
+    animatedModelResource,
+    animatedModelRenderer,
+
     -- * Accessors
-,   animationSpeed
-,   box
-,   currentAnimation
-,   currentFrame
-,   frameProgress
-,   modelRes
-,   nextFrame
+    animationSpeed,
+    box,
+    currentAnimation,
+    currentFrame,
+    frameProgress,
+    modelRes,
+    nextFrame,
+
     -- * Manipulation
-,   update
-,   setAnimation
-,   setAnimationSpeed
+    update,
+    setAnimation,
+    setAnimationSpeed,
+
     -- * Rendering
-,   bind
-,   render
+    bind,
+    render,
+
     -- * Collision
-,   mkColsFromAnimated
-)
+    mkColsFromAnimated,
+  )
 where
 
+import Control.Applicative ((<$>), (<*>))
+import qualified Data.Vector as V
 import Spear.Assets.Model
-import Spear.Game
 import Spear.GL
+import Spear.Game
 import Spear.Math.AABB
 import Spear.Math.Collision
 import Spear.Math.Matrix4 (Matrix4)
@@ -37,9 +43,6 @@ import Spear.Math.Vector
 import Spear.Render.Material
 import Spear.Render.Model
 import Spear.Render.Program
-
-import Control.Applicative ((<$>), (<*>))
-import qualified Data.Vector as V
 import Unsafe.Coerce (unsafeCoerce)
 
 type AnimationSpeed = Float
@@ -48,24 +51,25 @@ type AnimationSpeed = Float
 --
 -- Contains model data necessary to render an animated model.
 data AnimatedModelResource = AnimatedModelResource
-    { model     :: Model
-    , vao       :: VAO
-    , nFrames   :: Int
-    , nVertices :: Int
-    , material  :: Material
-    , texture   :: Texture
-    , boxes     :: V.Vector Box
-    , rkey      :: Resource
-    }
+  { model :: Model,
+    vao :: VAO,
+    nFrames :: Int,
+    nVertices :: Int,
+    material :: Material,
+    texture :: Texture,
+    boxes :: V.Vector Box,
+    rkey :: Resource
+  }
 
 instance Eq AnimatedModelResource where
-    m1 == m2 = vao m1 == vao m2
+  m1 == m2 = vao m1 == vao m2
 
 instance Ord AnimatedModelResource where
-    m1 < m2 = vao m1 < vao m2
+  m1 < m2 = vao m1 < vao m2
+  m1 <= m2 = vao m1 <= vao m2
 
 instance ResourceClass AnimatedModelResource where
-         getResource = rkey
+  getResource = rkey
 
 -- | An animated model renderer.
 --
@@ -78,83 +82,98 @@ instance ResourceClass AnimatedModelResource where
 -- state changes by sorting 'AnimatedModelRenderer's by their underlying
 -- 'AnimatedModelResource' when rendering the scene.
 data AnimatedModelRenderer = AnimatedModelRenderer
-    { modelResource  :: AnimatedModelResource
-    , currentAnim    :: Int
-    , frameStart     :: Int
-    , frameEnd       :: Int
-    , currentFrame   :: Int -- ^ Get the renderer's current frame.
-    , frameProgress  :: Float -- ^ Get the renderer's frame progress.
-    , animationSpeed :: Float -- ^ Get the renderer's animation speed.
-    }
+  { modelResource :: AnimatedModelResource,
+    currentAnim :: Int,
+    frameStart :: Int,
+    frameEnd :: Int,
+    -- | Get the renderer's current frame.
+    currentFrame :: Int,
+    -- | Get the renderer's frame progress.
+    frameProgress :: Float,
+    -- | Get the renderer's animation speed.
+    animationSpeed :: Float
+  }
 
 instance Eq AnimatedModelRenderer where
-    m1 == m2 = modelResource m1 == modelResource m2
+  m1 == m2 = modelResource m1 == modelResource m2
 
 instance Ord AnimatedModelRenderer where
-    m1 < m2 = modelResource m1 < modelResource m2
+  m1 < m2 = modelResource m1 < modelResource m2
+  m1 <= m2 = modelResource m1 <= modelResource m2
 
 -- | Create an model resource from the given model.
-animatedModelResource :: AnimatedProgramChannels
-                      -> Material
-                      -> Texture
-                      -> Model
-                      -> Game s AnimatedModelResource
-
+animatedModelResource ::
+  AnimatedProgramChannels ->
+  Material ->
+  Texture ->
+  Model ->
+  Game s AnimatedModelResource
 animatedModelResource
-    (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan)
-    material texture model = do
-        RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model
-        elementBuf <- newBuffer
-        vao        <- newVAO
-        boxes      <- gameIO $ modelBoxes model
-
-        gameIO $ do
-
-            let elemSize  = 56
-                elemSize' = fromIntegral elemSize
-                n         = numVertices * numFrames
-
-            bindVAO vao
-
-            bindBuffer ArrayBuffer elementBuf
-            bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw
-
-            attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0
-            attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12
-            attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24
-            attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36
-            attribVAOPointer texChan   2 gl_FLOAT False elemSize' 48
-
-            enableVAOAttrib vertChan1
-            enableVAOAttrib vertChan2
-            enableVAOAttrib normChan1
-            enableVAOAttrib normChan2
-            enableVAOAttrib texChan
-
-        rkey <- register $ do
-             putStrLn "Releasing animated model resource"
-             clean vao
-             clean elementBuf
-
-        return $ AnimatedModelResource
-            model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices)
-            material texture boxes rkey
+  (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan)
+  material
+  texture
+  model = do
+    RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model
+    elementBuf <- newBuffer
+    vao <- newVAO
+    boxes <- gameIO $ modelBoxes model
+
+    gameIO $ do
+      let elemSize = 56
+          elemSize' = fromIntegral elemSize
+          n = numVertices * numFrames
+
+      bindVAO vao
+
+      bindBuffer ArrayBuffer elementBuf
+      bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw
+
+      attribVAOPointer vertChan1 3 GL_FLOAT False elemSize' 0
+      attribVAOPointer vertChan2 3 GL_FLOAT False elemSize' 12
+      attribVAOPointer normChan1 3 GL_FLOAT False elemSize' 24
+      attribVAOPointer normChan2 3 GL_FLOAT False elemSize' 36
+      attribVAOPointer texChan 2 GL_FLOAT False elemSize' 48
+
+      enableVAOAttrib vertChan1
+      enableVAOAttrib vertChan2
+      enableVAOAttrib normChan1
+      enableVAOAttrib normChan2
+      enableVAOAttrib texChan
+
+    rkey <- register $ do
+      putStrLn "Releasing animated model resource"
+      clean vao
+      clean elementBuf
+
+    return $
+      AnimatedModelResource
+        model
+        vao
+        (unsafeCoerce numFrames)
+        (unsafeCoerce numVertices)
+        material
+        texture
+        boxes
+        rkey
 
 -- | Create a renderer from the given model resource.
 animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer
 animatedModelRenderer animSpeed modelResource =
-    AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed
+  AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed
 
 -- | Update the renderer.
 update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) =
-    AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s
-        where f = fp + dt * s
-              nextFrame = f >= 1.0
-              fp' = if nextFrame then f - 1.0 else f
-              curFrame' = if nextFrame
-                          then let x = curFrame + 1
-                               in if x > endFrame then startFrame else x
-                          else curFrame
+  AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s
+  where
+    f = fp + dt * s
+    nextFrame = f >= 1.0
+    fp' = if nextFrame then f - 1.0 else f
+    curFrame' =
+      if nextFrame
+        then
+          let x = curFrame + 1
+           in if x > endFrame then startFrame else x
+        else curFrame
 
 -- | Get the model's ith bounding box.
 box :: Int -> AnimatedModelResource -> Box
@@ -171,65 +190,65 @@ modelRes = modelResource
 -- | Get the renderer's next frame.
 nextFrame :: AnimatedModelRenderer -> Int
 nextFrame rend =
-    let curFrame = currentFrame rend
-    in
-        if curFrame == frameEnd rend
+  let curFrame = currentFrame rend
+   in if curFrame == frameEnd rend
         then frameStart rend
         else curFrame + 1
 
 -- | Set the active animation to the given one.
 setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer
 setAnimation anim modelRend =
-    let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim'
-        anim' = fromEnum anim
-    in
-        modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 }
+  let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim'
+      anim' = fromEnum anim
+   in modelRend {currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1}
 
 -- | Set the renderer's animation speed.
 setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer
-setAnimationSpeed s r = r { animationSpeed = s }
+setAnimationSpeed s r = r {animationSpeed = s}
 
 -- | Bind the given renderer to prepare it for rendering.
 bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
 bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend =
-    let model' = modelResource modelRend
-    in do
+  let model' = modelResource modelRend
+   in do
         bindVAO . vao $ model'
         bindTexture $ texture model'
-        activeTexture $= gl_TEXTURE0
+        activeTexture $= GL_TEXTURE0
         glUniform1i texLoc 0
 
 -- | Render the model described by the given renderer.
 render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
 render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) =
-    let n = nVertices model
-        (Material _ ka kd ks shi) = material model
-    in do
+  let n = nVertices model
+      (Material _ ka kd ks shi) = material model
+   in do
         uniform (kaLoc uniforms) ka
         uniform (kdLoc uniforms) kd
         uniform (ksLoc uniforms) ks
         glUniform1f (shiLoc uniforms) $ unsafeCoerce shi
         glUniform1f (fpLoc uniforms) (unsafeCoerce fp)
-        drawArrays gl_TRIANGLES (n*curFrame) n
+        drawArrays GL_TRIANGLES (n * curFrame) n
 
 -- | Compute AABB collisioners in view space from the given model.
-mkColsFromAnimated
-    :: Int     -- ^ Source frame
-    -> Int     -- ^ Dest frame
-    -> Float   -- ^ Frame progress
-    -> Matrix4 -- ^ Modelview matrix
-    -> AnimatedModelResource
-    -> [Collisioner2]
+mkColsFromAnimated ::
+  -- | Source frame
+  Int ->
+  -- | Dest frame
+  Int ->
+  -- | Frame progress
+  Float ->
+  -- | Modelview matrix
+  Matrix4 ->
+  AnimatedModelResource ->
+  [Collisioner2]
 mkColsFromAnimated f1 f2 fp modelview modelRes =
-    let
-        (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes
-        (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes
-        min1 = vec3 xmin1 ymin1 zmin1
-        max1 = vec3 xmax1 ymax1 zmax1
-        min2 = vec3 xmin2 ymin2 zmin2
-        max2 = vec3 xmax2 ymax2 zmax2
-        min = min1 + scale fp (min2 - min1)
-        max = max1 + scale fp (max2 - max1)
-    in
-        mkCols modelview
-            $ Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max))
+  let (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes
+      (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes
+      min1 = vec3 xmin1 ymin1 zmin1
+      max1 = vec3 xmax1 ymax1 zmax1
+      min2 = vec3 xmin2 ymin2 zmin2
+      max2 = vec3 xmax2 ymax2 zmax2
+      min = min1 + scale fp (min2 - min1)
+      max = max1 + scale fp (max2 - max1)
+   in mkCols modelview $
+        Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max))
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index 2e9804f..f0b141e 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -1,25 +1,29 @@
 module Spear.Render.StaticModel
-(
-    -- * Data types
-    StaticModelResource
-,   StaticModelRenderer
+  ( -- * Data types
+    StaticModelResource,
+    StaticModelRenderer,
+
     -- * Construction and destruction
-,   staticModelResource
-,   staticModelRenderer
+    staticModelResource,
+    staticModelRenderer,
+
     -- * Manipulation
-,   box
-,   modelRes
+    box,
+    modelRes,
+
     -- * Rendering
-,   bind
-,   render
+    bind,
+    render,
+
     -- * Collision
-,   mkColsFromStatic
-)
+    mkColsFromStatic,
+  )
 where
 
+import qualified Data.Vector as V
 import Spear.Assets.Model
-import Spear.Game
 import Spear.GL
+import Spear.Game
 import Spear.Math.AABB
 import Spear.Math.Collision
 import Spear.Math.Matrix4 (Matrix4)
@@ -27,75 +31,80 @@ import Spear.Math.Vector
 import Spear.Render.Material
 import Spear.Render.Model
 import Spear.Render.Program
-
-import qualified Data.Vector as V
 import Unsafe.Coerce (unsafeCoerce)
 
 data StaticModelResource = StaticModelResource
-    { vao       :: VAO
-    , nVertices :: Int
-    , material  :: Material
-    , texture   :: Texture
-    , boxes     :: V.Vector Box
-    , rkey      :: Resource
-    }
+  { vao :: VAO,
+    nVertices :: Int,
+    material :: Material,
+    texture :: Texture,
+    boxes :: V.Vector Box,
+    rkey :: Resource
+  }
 
 instance Eq StaticModelResource where
-    m1 == m2 = vao m1 == vao m2
+  m1 == m2 = vao m1 == vao m2
 
 instance Ord StaticModelResource where
-    m1 < m2 = vao m1 < vao m2
+  m1 < m2 = vao m1 < vao m2
+  m1 <= m2 = vao m1 <= vao m2
 
 instance ResourceClass StaticModelResource where
-         getResource = rkey
+  getResource = rkey
 
-data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource }
+data StaticModelRenderer = StaticModelRenderer {model :: StaticModelResource}
 
 instance Eq StaticModelRenderer where
-    m1 == m2 = model m1 == model m2
+  m1 == m2 = model m1 == model m2
 
 instance Ord StaticModelRenderer where
-    m1 < m2 = model m1 < model m2
+  m1 < m2 = model m1 < model m2
+  m1 <= m2 = model m1 <= model m2
 
 -- | Create a model resource from the given model.
-staticModelResource :: StaticProgramChannels
-                    -> Material
-                    -> Texture
-                    -> Model
-                    -> Game s StaticModelResource
-
+staticModelResource ::
+  StaticProgramChannels ->
+  Material ->
+  Texture ->
+  Model ->
+  Game s StaticModelResource
 staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do
-    RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model
-    elementBuf <- newBuffer
-    vao        <- newVAO
-    boxes      <- gameIO $ modelBoxes model
-
-    gameIO $ do
+  RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model
+  elementBuf <- newBuffer
+  vao <- newVAO
+  boxes <- gameIO $ modelBoxes model
 
-        let elemSize  = 32
-            elemSize' = fromIntegral elemSize
-            n         = numVertices
+  gameIO $ do
+    let elemSize = 32
+        elemSize' = fromIntegral elemSize
+        n = numVertices
 
-        bindVAO vao
+    bindVAO vao
 
-        bindBuffer ArrayBuffer elementBuf
-        bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw
+    bindBuffer ArrayBuffer elementBuf
+    bufferData' ArrayBuffer (fromIntegral $ elemSize * n) elements StaticDraw
 
-        attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0
-        attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12
-        attribVAOPointer texChan  2 gl_FLOAT False elemSize' 24
+    attribVAOPointer vertChan 3 GL_FLOAT False elemSize' 0
+    attribVAOPointer normChan 3 GL_FLOAT False elemSize' 12
+    attribVAOPointer texChan 2 GL_FLOAT False elemSize' 24
 
-        enableVAOAttrib vertChan
-        enableVAOAttrib normChan
-        enableVAOAttrib texChan
+    enableVAOAttrib vertChan
+    enableVAOAttrib normChan
+    enableVAOAttrib texChan
 
-    rkey <- register $ do
-        putStrLn "Releasing static model resource"
-        clean vao
-        clean elementBuf
+  rkey <- register $ do
+    putStrLn "Releasing static model resource"
+    clean vao
+    clean elementBuf
 
-    return $ StaticModelResource
-        vao (unsafeCoerce numVertices) material texture boxes rkey
+  return $
+    StaticModelResource
+      vao
+      (unsafeCoerce numVertices)
+      material
+      texture
+      boxes
+      rkey
 
 -- | Create a renderer from the given model resource.
 staticModelRenderer :: StaticModelResource -> StaticModelRenderer
@@ -112,27 +121,28 @@ modelRes = model
 -- | Bind the given renderer to prepare it for rendering.
 bind :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
 bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) =
-    let (Material _ ka kd ks shi) = material model
-    in do
+  let (Material _ ka kd ks shi) = material model
+   in do
         bindVAO . vao $ model
         bindTexture $ texture model
-        activeTexture $= gl_TEXTURE0
+        activeTexture $= GL_TEXTURE0
         glUniform1i texLoc 0
 
 -- | Render the given renderer.
 render :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
 render uniforms (StaticModelRenderer model) =
-    let (Material _ ka kd ks shi) = material model
-    in do
+  let (Material _ ka kd ks shi) = material model
+   in do
         uniform (kaLoc uniforms) ka
         uniform (kdLoc uniforms) kd
         uniform (ksLoc uniforms) ks
         glUniform1f (shiLoc uniforms) $ unsafeCoerce shi
-        drawArrays gl_TRIANGLES 0 $ nVertices model
+        drawArrays GL_TRIANGLES 0 $ nVertices model
 
 -- | Compute AABB collisioners in view space from the given model.
-mkColsFromStatic
-    :: Matrix4 -- ^ Modelview matrix
-    -> StaticModelResource
-    -> [Collisioner2]
+mkColsFromStatic ::
+  -- | Modelview matrix
+  Matrix4 ->
+  StaticModelResource ->
+  [Collisioner2]
 mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes)
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 7c072e8..a4a7ea2 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -1,22 +1,28 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Spear.Scene.Loader
-(
-    SceneResources(..)
-,   loadScene
-,   validate
-,   resourceMap
-,   value
-,   unspecified
-,   mandatory
-,   asString
-,   asFloat
-,   asVec3
-,   asVec4
-)
+  ( SceneResources (..),
+    loadScene,
+    validate,
+    resourceMap,
+    value,
+    unspecified,
+    mandatory,
+    asString,
+    asFloat,
+    asVec3,
+    asVec4,
+  )
 where
 
+import Control.Monad.State.Strict
+import Control.Monad.Trans (lift)
+import Data.List as L (find)
+import Data.Map as M
+import qualified Data.StateVar as SV (get)
 import Spear.Assets.Model as Model
-import Spear.Game
 import qualified Spear.GL as GL
+import Spear.Game
 import Spear.Math.Collision
 import Spear.Math.Matrix3 as M3
 import Spear.Math.Matrix4 as M4
@@ -28,12 +34,6 @@ import Spear.Render.Program
 import Spear.Render.StaticModel as SM
 import Spear.Scene.Graph
 import Spear.Scene.SceneResources
-
-import Control.Monad.State.Strict
-import Control.Monad.Trans (lift)
-import Data.List as L (find)
-import Data.Map as M
-import qualified Data.StateVar as SV (get)
 import Text.Printf (printf)
 
 type Loader = Game SceneResources
@@ -41,14 +41,14 @@ 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
-    case result of
-        Left err -> gameError $ show err
-        Right g  -> case validate g of
-            Nothing  -> do
-                sceneRes <- resourceMap g
-                return (sceneRes, g)
-            Just err -> gameError err
+  result <- gameIO $ loadSceneGraphFromFile file
+  case result of
+    Left err -> gameError $ show err
+    Right g -> case validate g of
+      Nothing -> do
+        sceneRes <- resourceMap g
+        return (sceneRes, g)
+      Just err -> gameError err
 
 -- | Validate the given SceneGraph.
 validate :: SceneGraph -> Maybe String
@@ -60,59 +60,63 @@ resourceMap g = execSubGame (resourceMap' g) emptySceneResources
 
 resourceMap' :: SceneGraph -> Loader ()
 resourceMap' node@(SceneLeaf nid props) = do
-    case nid of
-        "shader-program" -> newShaderProgram node
-        "model"          -> newModel         node
-        x                -> return ()
-
+  case nid of
+    "shader-program" -> newShaderProgram node
+    "model" -> newModel node
+    x -> return ()
 resourceMap' node@(SceneNode nid props children) = do
-    mapM_ resourceMap' children
+  mapM_ resourceMap' children
 
 -- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it.
-loadResource :: String -- ^ Resource name.
-             -> (SceneResources -> Map String a) -- ^ Map getter.
-             -> (String -> a -> Loader ()) -- ^ Function to modify resources.
-             -> Loader a -- ^ Resource loader.
-             -> Loader a
+loadResource ::
+  -- | Resource name.
+  String ->
+  -- | Map getter.
+  (SceneResources -> Map String a) ->
+  -- | Function to modify resources.
+  (String -> a -> Loader ()) ->
+  -- | Resource loader.
+  Loader a ->
+  Loader a
 loadResource key field modifyResources load = do
-    sceneData <- get
-    case M.lookup key $ field sceneData of
-        Just val -> return val
-        Nothing  -> do
-            gameIO $ printf "Loading %s..." key
-            resource <- load
-            gameIO $ printf "done\n"
-            modifyResources key resource
-            return resource
+  sceneData <- get
+  case M.lookup key $ field sceneData of
+    Just val -> return val
+    Nothing -> do
+      gameIO $ printf "Loading %s..." key
+      resource <- load
+      gameIO $ printf "done\n"
+      modifyResources key resource
+      return resource
 
 addShader name shader = modify $ \sceneData ->
-    sceneData { shaders = M.insert name shader $ shaders sceneData }
+  sceneData {shaders = M.insert name shader $ shaders sceneData}
 
 addCustomProgram name prog = modify $ \sceneData ->
-    sceneData { customPrograms = M.insert name prog $ customPrograms sceneData }
+  sceneData {customPrograms = M.insert name prog $ customPrograms sceneData}
 
 addStaticProgram name prog = modify $ \sceneData ->
-    sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData }
+  sceneData {staticPrograms = M.insert name prog $ staticPrograms sceneData}
 
 addAnimatedProgram name prog = modify $ \sceneData ->
-    sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData }
+  sceneData {animatedPrograms = M.insert name prog $ animatedPrograms sceneData}
 
 addTexture name tex = modify $ \sceneData ->
-    sceneData { textures = M.insert name tex $ textures sceneData }
+  sceneData {textures = M.insert name tex $ textures sceneData}
 
 addStaticModel name model = modify $
-    \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData }
+  \sceneData -> sceneData {staticModels = M.insert name model $ staticModels sceneData}
 
 addAnimatedModel name model = modify $
-    \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData }
+  \sceneData -> sceneData {animatedModels = M.insert name model $ animatedModels sceneData}
 
 -- Get the given resource from the data pool.
 getResource :: (SceneResources -> Map String a) -> String -> Loader a
 getResource field key = do
-    sceneData <- get
-    case M.lookup key $ field sceneData of
-        Just val -> return val
-        Nothing  -> gameError $ "Oops, the given resource has not been loaded: " ++ key
+  sceneData <- get
+  case M.lookup key $ field sceneData of
+    Just val -> return val
+    Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key
 
 ----------------------
 -- Resource Loading --
@@ -120,171 +124,170 @@ getResource field key = do
 
 newModel :: SceneGraph -> Loader ()
 newModel (SceneLeaf _ props) = do
-    name <- asString $ mandatory' "name"           props
-    file <- asString $ mandatory' "file"           props
-    tex  <- asString $ mandatory' "texture"        props
-    prog <- asString $ mandatory' "shader-program" props
-    ke   <- asVec4   $ mandatory' "ke"             props
-    ka   <- asVec4   $ mandatory' "ka"             props
-    kd   <- asVec4   $ mandatory' "kd"             props
-    ks   <- asVec4   $ mandatory' "ks"             props
-    shi  <- asFloat  $ mandatory' "shi"            props
-
-    let rotation = asRotation $ value "rotation" props
-        scale    = asVec3 $ value "scale" props
-
-    gameIO $ printf "Loading model %s..." name
-    model    <- loadModel' file rotation scale
-    gameIO .  putStrLn $ "done"
-    texture  <- loadTexture  tex
-    sceneRes <- get
-
-    let material = Material ke ka kd ks shi
-
-    case animated model of
-        False ->
-            case M.lookup prog $ staticPrograms sceneRes of
-                Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return ()
-                Just p  ->
-                    let StaticProgram _ channels _ = p
-                    in do
-                        model' <- staticModelResource channels material texture model
-                        loadResource name staticModels addStaticModel (return model')
-                        return ()
-        True ->
-            case M.lookup prog $ animatedPrograms sceneRes of
-                Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return ()
-                Just p  ->
-                    let AnimatedProgram _ channels _ = p
-                    in do
-                        model' <- animatedModelResource channels material texture model
-                        loadResource name animatedModels addAnimatedModel (return model')
-                        return ()
+  name <- asString $ mandatory' "name" props
+  file <- asString $ mandatory' "file" props
+  tex <- asString $ mandatory' "texture" props
+  prog <- asString $ mandatory' "shader-program" props
+  ke <- asVec4 $ mandatory' "ke" props
+  ka <- asVec4 $ mandatory' "ka" props
+  kd <- asVec4 $ mandatory' "kd" props
+  ks <- asVec4 $ mandatory' "ks" props
+  shi <- asFloat $ mandatory' "shi" props
+
+  let rotation = asRotation $ value "rotation" props
+      scale = asVec3 $ value "scale" props
+
+  gameIO $ printf "Loading model %s..." name
+  model <- loadModel' file rotation scale
+  gameIO . putStrLn $ "done"
+  texture <- loadTexture tex
+  sceneRes <- get
+
+  let material = Material ke ka kd ks shi
+
+  case animated model of
+    False ->
+      case M.lookup prog $ staticPrograms sceneRes of
+        Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return ()
+        Just p ->
+          let StaticProgram _ channels _ = p
+           in do
+                model' <- staticModelResource channels material texture model
+                loadResource name staticModels addStaticModel (return model')
+                return ()
+    True ->
+      case M.lookup prog $ animatedPrograms sceneRes of
+        Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return ()
+        Just p ->
+          let AnimatedProgram _ channels _ = p
+           in do
+                model' <- animatedModelResource channels material texture model
+                loadResource name animatedModels addAnimatedModel (return model')
+                return ()
 
 loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model
 loadModel' file rotation scale = do
-    let transform =
-            (case rotation of
-                Nothing  -> Prelude.id
-                Just rot -> rotateModel rot) .
-
-            (case scale of
+  let transform =
+        ( case rotation of
+            Nothing -> Prelude.id
+            Just rot -> rotateModel rot
+        )
+          . ( case scale of
                 Nothing -> Prelude.id
-                Just s  -> flip Model.transformVerts $
-                    \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z'))
+                Just s -> flip Model.transformVerts $
+                  \(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) >>= gameIO . toGround
 
 rotateModel :: Rotation -> Model -> Model
 rotateModel (Rotation ax ay az order) model =
-    let mat = case order of
-            XYZ -> rotZ az * rotY ay * rotX ax
-            XZY -> rotY ay * rotZ az * rotX ax
-            YXZ -> rotZ az * rotX ax * rotY ay
-            YZX -> rotX ax * rotZ az * rotY ay
-            ZXY -> rotY ay * rotX ax * rotZ az
-            ZYX -> rotX ax * rotY ay * rotZ az
-        normalMat = fastNormalMatrix mat
-
-        vTransform (Vec3 x' y' z') =
-            let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
-
-        nTransform (Vec3 x' y' z') =
-            let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
-    in
-        flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model
+  let mat = case order of
+        XYZ -> rotZ az * rotY ay * rotX ax
+        XZY -> rotY ay * rotZ az * rotX ax
+        YXZ -> rotZ az * rotX ax * rotY ay
+        YZX -> rotX ax * rotZ az * rotY ay
+        ZXY -> rotY ay * rotX ax * rotZ az
+        ZYX -> rotX ax * rotY ay * rotZ az
+      normalMat = fastNormalMatrix mat
+
+      vTransform (Vec3 x' y' z') =
+        let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
+
+      nTransform (Vec3 x' y' z') =
+        let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
+   in flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model
 
 loadTexture :: FilePath -> Loader GL.Texture
 loadTexture file =
-    loadResource file textures addTexture $
-        GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR
+  loadResource file textures addTexture $
+    GL.loadTextureImage file GL.GL_LINEAR GL.GL_LINEAR
 
 newShaderProgram :: SceneGraph -> Loader ()
 newShaderProgram (SceneLeaf _ props) = do
-    (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props
-    (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props
-    name       <- asString $ mandatory' "name" props
-    stype      <- asString $ mandatory' "type" props
-    prog       <- GL.newProgram [vertShader, fragShader]
-
-    let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name
-
-    case stype of
-        "static" -> do
-            ambient    <- asString $ mandatory' "ambient"    props
-            diffuse    <- asString $ mandatory' "diffuse"    props
-            specular   <- asString $ mandatory' "specular"   props
-            shininess  <- asString $ mandatory' "shininess"  props
-            texture    <- asString $ mandatory' "texture"    props
-            modelview  <- asString $ mandatory' "modelview"  props
-            normalmat  <- asString $ mandatory' "normalmat"  props
-            projection <- asString $ mandatory' "projection" props
-
-            ka    <- getUniformLoc ambient
-            kd    <- getUniformLoc diffuse
-            ks    <- getUniformLoc specular
-            shi   <- getUniformLoc shininess
-            tex   <- getUniformLoc texture
-            mview <- getUniformLoc modelview
-            nmat  <- getUniformLoc normalmat
-            proj  <- getUniformLoc projection
-
-            vertChan  <- fmap read $ asString $ mandatory' "vertex-channel" props
-            normChan  <- fmap read $ asString $ mandatory' "normal-channel" props
-            texChan    <- fmap read $ asString $ mandatory' "texture-channel" props
-
-            let channels = StaticProgramChannels vertChan normChan texChan
-                uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj
-
-            loadResource name staticPrograms addStaticProgram $
-                return $ StaticProgram prog channels uniforms
-            return ()
-
-        "animated" -> do
-            ambient    <- asString $ mandatory' "ambient"    props
-            diffuse    <- asString $ mandatory' "diffuse"    props
-            specular   <- asString $ mandatory' "specular"   props
-            shininess  <- asString $ mandatory' "shininess"  props
-            texture    <- asString $ mandatory' "texture"    props
-            modelview  <- asString $ mandatory' "modelview"  props
-            normalmat  <- asString $ mandatory' "normalmat"  props
-            projection <- asString $ mandatory' "projection" props
-
-            ka    <- getUniformLoc ambient
-            kd    <- getUniformLoc diffuse
-            ks    <- getUniformLoc specular
-            shi   <- getUniformLoc shininess
-            tex   <- getUniformLoc texture
-            mview <- getUniformLoc modelview
-            nmat  <- getUniformLoc normalmat
-            proj  <- getUniformLoc projection
-
-            vertChan1  <- fmap read $ asString $ mandatory' "vertex-channel1" props
-            vertChan2  <- fmap read $ asString $ mandatory' "vertex-channel2" props
-            normChan1  <- fmap read $ asString $ mandatory' "normal-channel1" props
-            normChan2  <- fmap read $ asString $ mandatory' "normal-channel2" props
-            texChan    <- fmap read $ asString $ mandatory' "texture-channel" props
-            fp <- asString $ mandatory' "fp" props
-            p  <- getUniformLoc fp
-
-            let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan
-                uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj
-
-            loadResource name animatedPrograms addAnimatedProgram $
-                return $ AnimatedProgram prog channels uniforms
-            return ()
-
-        _ -> do
-            loadResource name customPrograms addCustomProgram $ return prog
-            return ()
+  (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props
+  (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props
+  name <- asString $ mandatory' "name" props
+  stype <- asString $ mandatory' "type" props
+  prog <- GL.newProgram [vertShader, fragShader]
+
+  let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name
+
+  case stype of
+    "static" -> do
+      ambient <- asString $ mandatory' "ambient" props
+      diffuse <- asString $ mandatory' "diffuse" props
+      specular <- asString $ mandatory' "specular" props
+      shininess <- asString $ mandatory' "shininess" props
+      texture <- asString $ mandatory' "texture" props
+      modelview <- asString $ mandatory' "modelview" props
+      normalmat <- asString $ mandatory' "normalmat" props
+      projection <- asString $ mandatory' "projection" props
+
+      ka <- getUniformLoc ambient
+      kd <- getUniformLoc diffuse
+      ks <- getUniformLoc specular
+      shi <- getUniformLoc shininess
+      tex <- getUniformLoc texture
+      mview <- getUniformLoc modelview
+      nmat <- getUniformLoc normalmat
+      proj <- getUniformLoc projection
+
+      vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props
+      normChan <- fmap read $ asString $ mandatory' "normal-channel" props
+      texChan <- fmap read $ asString $ mandatory' "texture-channel" props
+
+      let channels = StaticProgramChannels vertChan normChan texChan
+          uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj
+
+      loadResource name staticPrograms addStaticProgram $
+        return $ StaticProgram prog channels uniforms
+      return ()
+    "animated" -> do
+      ambient <- asString $ mandatory' "ambient" props
+      diffuse <- asString $ mandatory' "diffuse" props
+      specular <- asString $ mandatory' "specular" props
+      shininess <- asString $ mandatory' "shininess" props
+      texture <- asString $ mandatory' "texture" props
+      modelview <- asString $ mandatory' "modelview" props
+      normalmat <- asString $ mandatory' "normalmat" props
+      projection <- asString $ mandatory' "projection" props
+
+      ka <- getUniformLoc ambient
+      kd <- getUniformLoc diffuse
+      ks <- getUniformLoc specular
+      shi <- getUniformLoc shininess
+      tex <- getUniformLoc texture
+      mview <- getUniformLoc modelview
+      nmat <- getUniformLoc normalmat
+      proj <- getUniformLoc projection
+
+      vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props
+      vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props
+      normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props
+      normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props
+      texChan <- fmap read $ asString $ mandatory' "texture-channel" props
+      fp <- asString $ mandatory' "fp" props
+      p <- getUniformLoc fp
+
+      let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan
+          uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj
+
+      loadResource name animatedPrograms addAnimatedProgram $
+        return $ AnimatedProgram prog channels uniforms
+      return ()
+    _ -> do
+      loadResource name customPrograms addCustomProgram $ return prog
+      return ()
 
 loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader)
 loadShader _ [] = gameError $ "Loader::vertexShader: empty list"
-loadShader shaderType ((stype, file):xs) =
-    if shaderType == GL.VertexShader   && stype == "vertex-shader" ||
-       shaderType == GL.FragmentShader && stype == "fragment-shader"
-    then let f = concat file
-         in loadShader' f shaderType >>= \shader -> return (f, shader)
+loadShader shaderType ((stype, file) : xs) =
+  if shaderType == GL.VertexShader && stype == "vertex-shader"
+    || shaderType == GL.FragmentShader && stype == "fragment-shader"
+    then
+      let f = concat file
+       in loadShader' f shaderType >>= \shader -> return (f, shader)
     else Spear.Scene.Loader.loadShader shaderType xs
 
 loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader
@@ -297,17 +300,17 @@ loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShade
 -- Get the value of the given key.
 value :: String -> [Property] -> Maybe [String]
 value name props = case L.find ((==) name . fst) props of
-    Nothing   -> Nothing
-    Just prop -> Just . snd $ prop
+  Nothing -> Nothing
+  Just prop -> Just . snd $ prop
 
 unspecified :: Maybe a -> a -> a
 unspecified (Just x) _ = x
-unspecified Nothing  x = x
+unspecified Nothing x = x
 
 mandatory :: String -> [Property] -> Game s [String]
 mandatory name props = case value name props of
-    Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name
-    Just x  -> return x
+  Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name
+  Just x -> return x
 
 mandatory' :: String -> [Property] -> Loader [String]
 mandatory' name props = mandatory name props
@@ -320,31 +323,35 @@ asFloat = fmap (read . concat)
 
 asVec2 :: Functor f => f [String] -> f Vector2
 asVec2 val = fmap toVec2 val
-    where toVec2 (x:y:_) = vec2 (read x) (read y)
-          toVec2 (x:[])    = let x' = read x in vec2 x' x'
+  where
+    toVec2 (x : y : _) = vec2 (read x) (read y)
+    toVec2 (x : []) = let x' = read x in vec2 x' x'
 
 asVec3 :: Functor f => f [String] -> f Vector3
 asVec3 val = fmap toVec3 val
-    where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z)
-          toVec3 (x:[])    = let x' = read x in vec3 x' x' x'
+  where
+    toVec3 (x : y : z : _) = vec3 (read x) (read y) (read z)
+    toVec3 (x : []) = let x' = read x in vec3 x' x' x'
 
 asVec4 :: Functor f => f [String] -> f Vector4
 asVec4 val = fmap toVec4 val
-    where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w)
-          toVec4 (x:[])      = let x' = read x in vec4 x' x' x' x'
+  where
+    toVec4 (x : y : z : w : _) = vec4 (read x) (read y) (read z) (read w)
+    toVec4 (x : []) = let x' = read x in vec4 x' x' x' x'
 
 asRotation :: Functor f => f [String] -> f Rotation
 asRotation val = fmap parseRotation val
-    where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order)
+  where
+    parseRotation (ax : ay : az : order : _) = Rotation (read ax) (read ay) (read az) (readOrder order)
 
 data Rotation = Rotation
-    { ax    :: Float
-    , ay    :: Float
-    , az    :: Float
-    , order :: RotationOrder
-    }
+  { ax :: Float,
+    ay :: Float,
+    az :: Float,
+    order :: RotationOrder
+  }
 
-data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq
+data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving (Eq)
 
 readOrder :: String -> RotationOrder
 readOrder "xyz" = XYZ
diff --git a/Spear/Step.hs b/Spear/Step.hs
index 26dfdc0..7419d9e 100644
--- a/Spear/Step.hs
+++ b/Spear/Step.hs
@@ -1,52 +1,60 @@
 {-# LANGUAGE FlexibleInstances #-}
+
 module Spear.Step
-(
-    -- * Definitions
-    Step
-,   Elapsed
-,   Dt
+  ( -- * Definitions
+    Step,
+    Elapsed,
+    Dt,
+
     -- * Running
-,   runStep
+    runStep,
+
     -- * Constructors
-,   step
-,   sid
-,   spure
-,   sfst
-,   ssnd
-,   sfold
+    step,
+    sid,
+    spure,
+    sfst,
+    ssnd,
+    sfold,
+
     -- * Combinators
-,   (.>)
-,   (<.)
-,   szip
-,   switch
-,   multiSwitch
-)
+    (.>),
+    (<.),
+    szip,
+    switch,
+    multiSwitch,
+  )
 where
 
 import Data.List (foldl')
-import qualified Data.Map as Map
 import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Monoid
 
 type Elapsed = Double
+
 type Dt = Float
 
 -- | A step function.
-data Step s e a b =
-     Step { runStep :: Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b) }
+newtype Step state events input a = Step
+  { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a)
+  }
 
 instance Functor (Step s e a) where
-         fmap f (Step s1) = Step $ \elapsed dt g e x ->
-              let (a, s') = s1 elapsed dt g e x
-              in (f a, fmap f s')
+  fmap f (Step s1) = Step $ \elapsed dt g e x ->
+    let (a, s') = s1 elapsed dt g e x
+     in (f a, fmap f s')
+
+instance Semigroup (Step s e a a) where
+  (<>) = (.>)
 
 instance Monoid (Step s e a a) where
-         mempty = sid
+  mempty = sid
 
-         mappend (Step s1) (Step s2) = Step $ \elapsed dt g e a ->
-                 let (b, s1') = s1 elapsed dt g e a
-                     (c, s2') = s2 elapsed dt g e b
-                 in (c, mappend s1' s2')
+  mappend (Step s1) (Step s2) = Step $ \elapsed dt g e a ->
+    let (b, s1') = s1 elapsed dt g e a
+        (c, s2') = s2 elapsed dt g e b
+     in (c, mappend s1' s2')
 
 -- | Construct a step from a function.
 step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b
@@ -61,40 +69,47 @@ spure :: (a -> b) -> Step s e a b
 spure f = Step $ \_ _ _ _ x -> (f x, spure f)
 
 -- | The step that returns the first component in the tuple.
-sfst :: Step s e (a,b) a
-sfst = spure $ \(a,_) -> a
+sfst :: Step s e (a, b) a
+sfst = spure $ \(a, _) -> a
 
 -- | The step that returns the second component in the tuple.
-ssnd :: Step s e (a,b) b
-ssnd = spure $ \(_,b) -> b
+ssnd :: Step s e (a, b) b
+ssnd = spure $ \(_, b) -> b
 
 -- | Construct a step that folds a given list of inputs.
 --
 -- The step is run N+1 times, where N is the size of the input list.
 sfold :: Step s (Maybe e) a a -> Step s [e] a a
 sfold s = Step $ \elapsed dt g es a ->
-      case es of
-           [] ->
-              let (b',s') = runStep s elapsed dt g Nothing a
-              in (b', sfold s')
-           es ->
-              let (b',s') = sfold' elapsed dt g s a es
-              in (b', sfold s')
-
-sfold' :: Elapsed -> Dt -> s -> Step s (Maybe e) a a -> a -> [e]
-       -> (a, Step s (Maybe e) a a)
-sfold' elapsed dt g s a es = foldl' f (a',s') es
-       where f (a,s) e = runStep s elapsed dt g (Just e) a
-             (a',s') = runStep s elapsed dt g Nothing a
+  case es of
+    [] ->
+      let (b', s') = runStep s elapsed dt g Nothing a
+       in (b', sfold s')
+    es ->
+      let (b', s') = sfold' elapsed dt g s a es
+       in (b', sfold s')
+
+sfold' ::
+  Elapsed ->
+  Dt ->
+  s ->
+  Step s (Maybe e) a a ->
+  a ->
+  [e] ->
+  (a, Step s (Maybe e) a a)
+sfold' elapsed dt g s a es = foldl' f (a', s') es
+  where
+    f (a, s) e = runStep s elapsed dt g (Just e) a
+    (a', s') = runStep s elapsed dt g Nothing a
 
 -- Combinators
 
 -- | Compose two steps.
 (.>) :: Step s e a b -> Step s e b c -> Step s e a c
 (Step s1) .> (Step s2) = Step $ \elapsed dt g e a ->
-      let (b, s1') = s1 elapsed dt g e a
-          (c, s2') = s2 elapsed dt g e b
-      in (c, s1' .> s2')
+  let (b, s1') = s1 elapsed dt g e a
+      (c, s2') = s2 elapsed dt g e b
+   in (c, s1' .> s2')
 
 -- | Compose two steps.
 (<.) :: Step s e a b -> Step s e c a -> Step s e c b
@@ -103,53 +118,67 @@ sfold' elapsed dt g s a es = foldl' f (a',s') es
 -- | Evaluate two steps and zip their results.
 szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c
 szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d ->
-     let (a, s1') = s1 elapsed dt g e d
-         (b, s2') = s2 elapsed dt g e d
-     in (f a b, szip f s1' s2')
+  let (a, s1') = s1 elapsed dt g e d
+      (b, s2') = s2 elapsed dt g e d
+   in (f a b, szip f s1' s2')
 
 -- | Construct a step that switches between two steps based on input.
 --
 -- The initial step is the first one.
-switch :: Eq e
-       => e -> (Step s (Maybe e) a a)
-       -> e -> (Step s (Maybe e) a a)
-       -> Step s (Maybe e) a a
+switch ::
+  Eq e =>
+  e ->
+  (Step s (Maybe e) a a) ->
+  e ->
+  (Step s (Maybe e) a a) ->
+  Step s (Maybe e) a a
 switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2
 
-switch' :: Eq e
-        => (Step s (Maybe e) a a)
-        -> e -> (Step s (Maybe e) a a)
-        -> e -> (Step s (Maybe e) a a)
-        -> Step s (Maybe e) a a
+switch' ::
+  Eq e =>
+  (Step s (Maybe e) a a) ->
+  e ->
+  (Step s (Maybe e) a a) ->
+  e ->
+  (Step s (Maybe e) a a) ->
+  Step s (Maybe e) a a
 switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a ->
-        case e of
-             Nothing ->
-                     let (a',s') = runStep cur elapsed dt g Nothing a
-                     in (a', switch' s' flag1 s1 flag2 s2)
-             Just e' ->
-                     let next = if e' == flag1 then s1
-                                else if e' == flag2 then s2
-                                else cur
-                         (a',s') = runStep next elapsed dt g e a
-                         in (a', switch' s' flag1 s1 flag2 s2)
+  case e of
+    Nothing ->
+      let (a', s') = runStep cur elapsed dt g Nothing a
+       in (a', switch' s' flag1 s1 flag2 s2)
+    Just e' ->
+      let next =
+            if e' == flag1
+              then s1
+              else
+                if e' == flag2
+                  then s2
+                  else cur
+          (a', s') = runStep next elapsed dt g e a
+       in (a', switch' s' flag1 s1 flag2 s2)
 
 -- | Construct a step that switches among multiple steps based on input.
 multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a
 multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs)
 
-multiSwitch' :: (Eq e, Ord e)
-             => Maybe e -> Step s (Maybe e) a a -> Map e (Step s (Maybe e) a a)
-             -> Step s (Maybe e) a a
+multiSwitch' ::
+  (Eq e, Ord e) =>
+  Maybe e ->
+  Step s (Maybe e) a a ->
+  Map e (Step s (Maybe e) a a) ->
+  Step s (Maybe e) a a
 multiSwitch' curKey cur m = Step $ \elapsed dt g e a ->
-             let singleStep = let (a',s') = runStep cur elapsed dt g e a
-                              in (a', multiSwitch' curKey s' m)
-             in case e of
-                     Nothing -> singleStep
-                     Just e' -> case Map.lookup e' m of
-                          Nothing -> singleStep
-                          Just s ->
-                               let (a',s') = runStep s elapsed dt g e a
-                                   m' = case curKey of
-                                             Nothing  -> m
-                                             Just key -> Map.insert key cur m
-                               in (a', multiSwitch' e s' m')
\ No newline at end of file
+  let singleStep =
+        let (a', s') = runStep cur elapsed dt g e a
+         in (a', multiSwitch' curKey s' m)
+   in case e of
+        Nothing -> singleStep
+        Just e' -> case Map.lookup e' m of
+          Nothing -> singleStep
+          Just s ->
+            let (a', s') = runStep s elapsed dt g e a
+                m' = case curKey of
+                  Nothing -> m
+                  Just key -> Map.insert key cur m
+             in (a', multiSwitch' e s' m')
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc
index 60ae9d7..85718ce 100644
--- a/Spear/Sys/Timer.hsc
+++ b/Spear/Sys/Timer.hsc
@@ -45,7 +45,7 @@ instance Storable Timer where
 
          peek ptr = do
               baseTime   <- #{peek Timer, baseTime}   ptr
-	      pausedTime <- #{peek Timer, pausedTime} ptr
+              pausedTime <- #{peek Timer, pausedTime} ptr
               stopTime   <- #{peek Timer, stopTime}   ptr
               prevTime   <- #{peek Timer, prevTime}   ptr
               curTime    <- #{peek Timer, curTime}    ptr
@@ -63,31 +63,31 @@ instance Storable Timer where
               #{poke Timer, stopped}    ptr stopped
 
 foreign import ccall unsafe "Timer.h timer_init"
-	c_timer_init :: Ptr Timer -> IO ()
+     c_timer_init :: Ptr Timer -> IO ()
 
 foreign import ccall unsafe "Timer.h timer_tick"
-	c_timer_tick :: Ptr Timer -> IO ()
+     c_timer_tick :: Ptr Timer -> IO ()
 
 foreign import ccall unsafe "Timer.h timer_start"
-	c_timer_start :: Ptr Timer -> IO ()
+     c_timer_start :: Ptr Timer -> IO ()
 
 foreign import ccall unsafe "Timer.h timer_stop"
-	c_timer_stop :: Ptr Timer -> IO ()
+     c_timer_stop :: Ptr Timer -> IO ()
 
 foreign import ccall unsafe "Timer.h timer_reset"
-	c_timer_reset :: Ptr Timer -> IO ()
+     c_timer_reset :: Ptr Timer -> IO ()
 
 foreign import ccall unsafe "Timer.h timer_get_time"
-	c_timer_get_time :: Ptr Timer -> IO (CDouble)
+     c_timer_get_time :: Ptr Timer -> IO (CDouble)
 
 foreign import ccall unsafe "Timer.h timer_get_delta"
-	c_timer_get_delta :: Ptr Timer -> IO (CFloat)
+     c_timer_get_delta :: Ptr Timer -> IO (CFloat)
 
 foreign import ccall unsafe "Timer.h timer_is_running"
-	c_timer_is_running :: Ptr Timer -> IO (CChar)
+     c_timer_is_running :: Ptr Timer -> IO (CChar)
 
 foreign import ccall "Timer.h timer_sleep"
-	c_timer_sleep :: CFloat -> IO ()
+     c_timer_sleep :: CFloat -> IO ()
 
 -- | Construct a new timer.
 newTimer :: Timer
@@ -105,10 +105,10 @@ tick t = alloca $ \tptr -> do
 -- | Start the timer.
 start :: Timer -> IO (Timer)
 start t = alloca $ \tptr -> do
-	poke tptr t
-	c_timer_start tptr
-	t' <- peek tptr
-	return t'
+     poke tptr t
+     c_timer_start tptr
+     t' <- peek tptr
+     return t'
 
 -- | Stop the timer.
 stop :: Timer -> IO (Timer)
@@ -120,30 +120,30 @@ stop t = alloca $ \tptr -> do
 -- | Reset the timer.
 reset :: Timer -> IO (Timer)
 reset t = alloca $ \tptr -> do
-      poke tptr t
-      c_timer_reset tptr
-      peek tptr
+     poke tptr t
+     c_timer_reset tptr
+     peek tptr
 
 -- | Get the timer's total running time.
 getTime :: Timer -> Double
 getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do
-        poke tptr t
-        time <- c_timer_get_time tptr
-        return (realToFrac time)
+     poke tptr t
+     time <- c_timer_get_time tptr
+     return (realToFrac time)
 
 -- | Get the time elapsed between the last two ticks.
 getDelta :: Timer -> Float
 getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do
-         poke tptr t
-         dt <- c_timer_get_delta tptr
-         return (realToFrac dt)
+     poke tptr t
+     dt <- c_timer_get_delta tptr
+     return (realToFrac dt)
 
 -- | Return true if the timer is running (not stopped), false otherwise.
 isRunning :: Timer -> Bool
 isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do
-          poke tptr t
-          running <- c_timer_is_running tptr
-          return (running /= 0)
+     poke tptr t
+     running <- c_timer_is_running tptr
+     return (running /= 0)
 
 -- | Put the caller thread to sleep for the given number of seconds.
 sleep :: Float -> IO ()
diff --git a/Spear/Window.hs b/Spear/Window.hs
index 2e06d72..85a3dc8 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -1,53 +1,55 @@
 module Spear.Window
-(
-    -- * Setup
-    Dimensions
-,   Context
-,   WindowTitle
-,   FrameCap
-,   DisplayBits(..)
-,   WindowMode(..)
+  ( -- * Setup
+    Dimensions,
+    Context,
+    WindowTitle,
+    FrameCap,
+
     -- * Window
-,   Window
-,   Width
-,   Height
-,   Init
-,   run
-,   withWindow
-,   events
+    Window,
+    Width,
+    Height,
+    Init,
+    withWindow,
+    events,
+
     -- * Animation
-,   Elapsed
-,   Dt
-,   Step
-,   loop
-,   GLFW.swapBuffers
+    Elapsed,
+    Dt,
+    Step,
+    loop,
+    GLFW.swapBuffers,
+
     -- * Input
-,   whenKeyDown
-,   whenKeyUp
-,   processKeys
-,   processButtons
-,   InputEvent(..)
-,   Key(..)
-,   MouseButton(..)
-,   MouseProp(..)
-,   MousePos
-,   MouseDelta
-)
+    whenKeyDown,
+    whenKeyUp,
+    processKeys,
+    processButtons,
+    InputEvent (..),
+    Key (..),
+    MouseButton (..),
+    MouseProp (..),
+    MousePos,
+    MouseDelta,
+  )
 where
 
-import Spear.Game
-import Spear.Sys.Timer as Timer
-
-import Data.Char (ord)
 import Control.Concurrent.MVar
-import Control.Monad (when, foldM)
+import Control.Exception
+import Control.Monad (foldM, unless, void, when)
 import Control.Monad.IO.Class
+import Data.Char (ord)
+import Data.Maybe (fromJust, fromMaybe, isJust)
 import GHC.Float
-import qualified Graphics.UI.GLFW as GLFW
-import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..))
 import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.UI.GLFW as GLFW
+import Spear.Game
+import Spear.Sys.Timer as Timer
+
+maxFPS = 60
+
+type Width = Int
 
-type Width  = Int
 type Height = Int
 
 -- | Window dimensions.
@@ -62,85 +64,75 @@ type CloseRequest = MVar Bool
 
 -- | A window.
 data Window = Window
-     { closeRequest :: CloseRequest
-     , inputEvents  :: MVar [InputEvent]
-     }
+  { glfwWindow :: GLFW.Window,
+    closeRequest :: CloseRequest,
+    inputEvents :: MVar [InputEvent]
+  }
 
 -- | Poll the window's events.
 events :: MonadIO m => Window -> m [InputEvent]
-events wnd = liftIO $ do
-       es <- tryTakeMVar (inputEvents wnd) >>= \xs -> case xs of
-                         Nothing -> return []
-                         Just es -> return es
-       putMVar (inputEvents wnd) []
-       return es
+events window = liftIO $ do
+  es <-
+    tryTakeMVar (inputEvents window) >>= \xs -> case xs of
+      Nothing -> return []
+      Just es -> return es
+  putMVar (inputEvents window) []
+  return es
 
 -- | Game initialiser.
 type Init s = Window -> Game () s
 
-run :: MonadIO m => m (Either String a) -> m ()
-run r = do
-      result <- r
-      case result of
-           Left err -> liftIO $ putStrLn err
-           Right _ -> return ()
-
-withWindow :: MonadIO m
-           => Dimensions -> [DisplayBits] -> WindowMode -> Context
-           -> Maybe WindowTitle
-           -> Init s
-           -> (Window -> Game s a)
-           -> m (Either String a)
-withWindow dim@(w,h) displayBits windowMode glVersion windowTitle init run =
-           liftIO $ flip runGame' () $ do
-                  glfwInit
-                  wnd <- setup dim displayBits windowMode glVersion windowTitle
-                  gameState <- init wnd
-                  result <- evalSubGame (run wnd) gameState
-                  gameIO GLFW.closeWindow
-                  gameIO GLFW.terminate
-                  return result
-
-setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle
-      -> Game s Window
-setup (w, h) displayBits windowMode (major, minor) wndTitle = do
-        closeRequest <- liftIO newEmptyMVar
-        inputEvents  <- liftIO newEmptyMVar
-        let onResize' = onResize inputEvents
-        let dimensions = GL.Size (fromIntegral w) (fromIntegral h)
-        result <- liftIO $ do
-               GLFW.openWindowHint GLFW.OpenGLVersionMajor major
-               GLFW.openWindowHint GLFW.OpenGLVersionMinor minor
-               compat (major, minor)
-               GLFW.disableSpecial GLFW.AutoPollEvent
-               GLFW.openWindow dimensions (defaultBits displayBits) windowMode
-        when (not result) $ gameError "GLFW.openWindow failed"
-        liftIO $ do
-               GLFW.windowTitle GL.$= case wndTitle of
-                                      Nothing    -> "Spear Game Framework"
-                                      Just title -> title
-               GLFW.windowCloseCallback GL.$= (onWindowClose closeRequest)
-               GLFW.windowSizeCallback GL.$= onResize'
-               GLFW.keyCallback GL.$= onKey inputEvents
-               GLFW.charCallback GL.$= onChar inputEvents
-               GLFW.mouseButtonCallback GL.$= onMouseButton inputEvents
-               onMouseMove inputEvents >>= (GLFW.mousePosCallback GL.$=)
-               onResize' (GL.Size (fromIntegral w) (fromIntegral h))
-        return $ Spear.Window.Window closeRequest inputEvents
-
-defaultBits [] = [DisplayRGBBits 8 8 8]
-defaultBits xs = xs
-
-compat (major, minor)
-       | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile
-       | otherwise  = return ()
+withWindow ::
+  Dimensions ->
+  Context ->
+  Maybe WindowTitle ->
+  Init s ->
+  (Window -> Game s a) ->
+  IO a
+withWindow dim@(w, h) glVersion windowTitle init run = do
+  flip runGame' () $ do
+    glfwInit
+    window <- setup dim glVersion windowTitle
+    gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window)
+    gameState <- init window
+    result <- evalSubGame (run window) gameState
+    gameIO $ do
+      GLFW.destroyWindow $ glfwWindow window
+      GLFW.terminate
+    return result
+
+setup ::
+  Dimensions ->
+  Context ->
+  Maybe WindowTitle ->
+  Game s Window
+setup (w, h) (major, minor) windowTitle = do
+  closeRequest <- gameIO newEmptyMVar
+  inputEvents <- gameIO newEmptyMVar
+  let onResize' = onResize inputEvents
+  let title = fromMaybe "" windowTitle
+  let monitor = Nothing
+  maybeWindow <- gameIO $ do
+    GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major
+    GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor
+    when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat
+    GLFW.createWindow w h title monitor Nothing
+  unless (isJust maybeWindow) $ gameError "GLFW.openWindow failed"
+  let window = fromJust maybeWindow
+  liftIO $ do
+    GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
+    GLFW.setWindowSizeCallback window . Just $ onResize'
+    GLFW.setKeyCallback window . Just $ onKey inputEvents
+    GLFW.setCharCallback window . Just $ onChar inputEvents
+    GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents
+    onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just
+    onResize' window w h
+  return $ Spear.Window.Window window closeRequest inputEvents
 
 glfwInit :: Game s ()
 glfwInit = do
-         result <- liftIO GLFW.initialize
-         case result of
-              False -> gameError "GLFW.initialize failed"
-              True  -> return ()
+  result <- gameIO GLFW.init
+  if result then return () else gameError "GLFW.initialize failed"
 
 -- | Time elapsed since the application started.
 type Elapsed = Double
@@ -149,279 +141,331 @@ type Elapsed = Double
 type Dt = Float
 
 -- | Return true if the application should continue running, false otherwise.
-type Step s = Elapsed -> Dt -> Game s (Bool)
+type Step s = Elapsed -> Dt -> Game s Bool
 
 -- | Maximum frame rate.
 type FrameCap = Int
 
--- | Run the application's main loop.
-loop :: Maybe FrameCap -> Step s -> Window -> Game s ()
-loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd
-loop Nothing step wnd = do
-     timer <- gameIO $ start newTimer
-     loop' (closeRequest wnd) timer 0 step
-     return ()
-
-loop' :: CloseRequest -> Timer -> Elapsed -> Step s -> Game s ()
-loop' closeRequest timer elapsed step = do
-      timer' <- gameIO $ tick timer
-      let dt       = getDelta timer'
-      let elapsed' = elapsed + float2Double dt
-      continue <- step elapsed' dt
-      close    <- gameIO $ getRequest closeRequest
-      when (continue && (not close)) $ loop' closeRequest timer' elapsed' step
-
-loopCapped :: Int -> Step s -> Window -> Game s ()
-loopCapped maxFPS step wnd = do
-           let ddt = 1.0 / (fromIntegral maxFPS)
-               closeReq = closeRequest wnd
-           frameTimer   <- gameIO $ start newTimer
-           controlTimer <- gameIO $ start newTimer
-           loopCapped' closeReq ddt frameTimer controlTimer 0 step
-           return ()
-
-loopCapped' :: CloseRequest -> Float -> Timer -> Timer -> Elapsed -> Step s
-            -> Game s ()
-loopCapped' closeRequest ddt frameTimer controlTimer elapsed step = do
-            controlTimer'  <- gameIO $ tick controlTimer
-            frameTimer'    <- gameIO $ tick frameTimer
-            let dt         = getDelta frameTimer'
-            let elapsed'   = elapsed + float2Double dt
-            continue       <- step elapsed' dt
-            close          <- gameIO $ getRequest closeRequest
-            controlTimer'' <- gameIO $ tick controlTimer'
-            let dt = getDelta controlTimer''
-            when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
-            when (continue && (not close)) $
-                 loopCapped' closeRequest ddt frameTimer' controlTimer''
-                             elapsed' step
+loop :: Step s -> Window -> Game s ()
+loop step window = do
+  let ddt = 1.0 / fromIntegral maxFPS
+      closeReq = closeRequest window
+  frameTimer <- gameIO $ start newTimer
+  controlTimer <- gameIO $ start newTimer
+  loop' window closeReq ddt frameTimer controlTimer 0 step
+  return ()
+
+loop' ::
+  Window ->
+  CloseRequest ->
+  Float ->
+  Timer ->
+  Timer ->
+  Elapsed ->
+  Step s ->
+  Game s ()
+loop' window closeRequest ddt frameTimer controlTimer elapsed step = do
+  controlTimer' <- gameIO $ tick controlTimer
+  frameTimer' <- gameIO $ tick frameTimer
+  let dt = getDelta frameTimer'
+  let elapsed' = elapsed + float2Double dt
+  gameIO GLFW.pollEvents
+  continue <- step elapsed' dt
+  gameIO . GLFW.swapBuffers $ glfwWindow window
+  close <- gameIO $ getRequest closeRequest
+  controlTimer'' <- gameIO $ tick controlTimer'
+  let dt = getDelta controlTimer''
+  when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
+  when (continue && not close) $
+    loop'
+      window
+      closeRequest
+      ddt
+      frameTimer'
+      controlTimer''
+      elapsed'
+      step
 
 getRequest :: MVar Bool -> IO Bool
-getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of
-           Nothing -> False
-           Just x  -> x
+getRequest mvar =
+  tryTakeMVar mvar >>= \x -> return $ fromMaybe False x
 
 onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback
-onWindowClose closeRequest = putMVar closeRequest True >> return False
+onWindowClose closeRequest window = do putMVar closeRequest True
 
 onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback
-onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h)
+onResize events window w h = addEvent events $ Resize w h
 
 onKey :: MVar [InputEvent] -> GLFW.KeyCallback
-onKey es key GLFW.Press   = addEvent es $ KeyDown (fromGLFWkey key)
-onKey es key GLFW.Release = addEvent es $ KeyUp   (fromGLFWkey key)
+onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key)
+onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key)
+onKey events window key _ GLFW.KeyState'Repeating _ = return ()
 
 onChar :: MVar [InputEvent] -> GLFW.CharCallback
-onChar es c GLFW.Press   = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c))
-onChar es c GLFW.Release = addEvent es $ KeyUp   (fromGLFWkey (GLFW.CharKey c))
+onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char]
 
 onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
-onMouseButton es bt GLFW.Press   = addEvent es $ MouseDown (fromGLFWbutton bt)
-onMouseButton es bt GLFW.Release = addEvent es $ MouseUp   (fromGLFWbutton bt)
-
-onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback
-onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es
-
-onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback
-onMouseMove' oldPos es (GL.Position x y) = do
-             let (x',y') = (fromIntegral x, fromIntegral y)
-             (old_x, old_y) <- tryTakeMVar oldPos >>= \x -> case x of
-                  Nothing -> return (x',y')
-                  Just p  -> return p
-             let delta = (x'-old_x, y'-old_y)
-             putMVar oldPos (x',y')
-             addEvent es $ MouseMove (x',y') delta
+onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button)
+onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button)
+
+onMouseMove :: MVar [InputEvent] -> IO GLFW.CursorPosCallback
+onMouseMove events = newEmptyMVar >>= return . flip onMouseMove' events
+
+onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback
+onMouseMove' oldPos events window x y = do
+  (old_x, old_y) <-
+    tryTakeMVar oldPos >>= \old -> case old of
+      Nothing -> return (x, y)
+      Just p -> return p
+  let delta = (x - old_x, y - old_y)
+  putMVar oldPos (x, y)
+  addEvent events $ MouseMove (x, y) delta
 
 replaceMVar :: MVar a -> a -> IO ()
 replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val
 
 addEvent :: MVar [a] -> a -> IO ()
-addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of
-         Nothing -> putMVar mvar [val]
-         Just es -> putMVar mvar (val:es)
+addEvent mvar val =
+  tryTakeMVar mvar >>= \xs -> case xs of
+    Nothing -> putMVar mvar [val]
+    Just events -> putMVar mvar (val : events)
 
 -- Input
 
 -- | Run the game action when the key is down.
-whenKeyDown :: Key -> Game s a -> Game s ()
-whenKeyDown = whenKey (==GLFW.Press)
+whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s ()
+whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed)
 
 -- | Run the game action when the key is up.
-whenKeyUp :: Key -> Game s a -> Game s ()
-whenKeyUp = whenKey (==GLFW.Release)
+whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s ()
+whenKeyUp = whenKeyInState (== GLFW.KeyState'Released)
 
-whenKey :: (GLFW.KeyButtonState -> Bool) -> Key -> Game s a -> Game s ()
-whenKey pred key game = do
-            isDown <- fmap pred $ gameIO . GLFW.getKey . toGLFWkey $ key
-            when isDown $ game >> return ()
+whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s ()
+whenKeyInState pred window key game = do
+  isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key
+  when isDown $ void game
 
 -- | Process the keyboard keys, returning those values for which their
 -- corresponding key is pressed.
-processKeys :: [(Key,a)] -> Game s [a]
-processKeys = foldM f []
-            where f acc (key,res) = do
-                  isDown <- fmap (==GLFW.Press) $ gameIO . GLFW.getKey
-                         . toGLFWkey $ key
-                  return $ if isDown then (res:acc) else acc
+processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a]
+processKeys window = foldM f []
+  where
+    f acc (key, result) = do
+      isDown <-
+        fmap (== GLFW.KeyState'Pressed) $
+          gameIO . GLFW.getKey window . toGLFWkey $ key
+      return $ if isDown then result : acc else acc
 
 -- | Process the mouse buttons, returning those values for which their
 -- corresponding button is pressed.
-processButtons :: [(MouseButton,a)] -> Game s [a]
-processButtons = foldM f []
-               where f acc (bt,res) = do
-                     isDown <- fmap (==GLFW.Press) $ gameIO . GLFW.getMouseButton
-                            . toGLFWbutton $ bt
-                     return $ if isDown then (res:acc) else acc
+processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a]
+processButtons window = foldM f []
+  where
+    f acc (button, result) = do
+      isDown <-
+        fmap (== GLFW.MouseButtonState'Pressed) $
+          gameIO . GLFW.getMouseButton window . toGLFWbutton $ button
+      return $ if isDown then result : acc else acc
 
 data InputEvent
-     = Resize Width Height
-     | KeyDown Key
-     | KeyUp Key
-     | MouseDown MouseButton
-     | MouseUp MouseButton
-     | MouseMove MousePos MouseDelta
-     deriving (Eq, Show)
+  = Resize Width Height
+  | KeyDown Key
+  | KeyUp Key
+  | MouseDown MouseButton
+  | MouseUp MouseButton
+  | MouseMove MousePos MouseDelta
+  deriving (Eq, Show)
 
 data Key
-     = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H
-     | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P
-     | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X
-     | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5
-     | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3
-     | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10
-     | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN
-     | KEY_LEFT | KEY_RIGHT | KEY_UNKNOWN
-     deriving (Eq, Enum, Bounded, Show)
+  = KEY_A
+  | KEY_B
+  | KEY_C
+  | KEY_D
+  | KEY_E
+  | KEY_F
+  | KEY_G
+  | KEY_H
+  | KEY_I
+  | KEY_J
+  | KEY_K
+  | KEY_L
+  | KEY_M
+  | KEY_N
+  | KEY_O
+  | KEY_P
+  | KEY_Q
+  | KEY_R
+  | KEY_S
+  | KEY_T
+  | KEY_U
+  | KEY_V
+  | KEY_W
+  | KEY_X
+  | KEY_Y
+  | KEY_Z
+  | KEY_0
+  | KEY_1
+  | KEY_2
+  | KEY_3
+  | KEY_4
+  | KEY_5
+  | KEY_6
+  | KEY_7
+  | KEY_8
+  | KEY_9
+  | KEY_F1
+  | KEY_F2
+  | KEY_F3
+  | KEY_F4
+  | KEY_F5
+  | KEY_F6
+  | KEY_F7
+  | KEY_F8
+  | KEY_F9
+  | KEY_F10
+  | KEY_F11
+  | KEY_F12
+  | KEY_ESC
+  | KEY_SPACE
+  | KEY_UP
+  | KEY_DOWN
+  | KEY_LEFT
+  | KEY_RIGHT
+  | KEY_UNKNOWN
+  deriving (Eq, Enum, Bounded, Show)
 
 data MouseButton = LMB | RMB | MMB
-    deriving (Eq, Enum, Bounded, Show)
+  deriving (Eq, Enum, Bounded, Show)
 
 data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta
-    deriving (Eq, Enum, Bounded, Show)
+  deriving (Eq, Enum, Bounded, Show)
 
-type MousePos = (Int,Int)
-type MouseDelta = (Int,Int)
+type MousePos = (Double, Double)
+
+type MouseDelta = (Double, Double)
 
 fromGLFWkey :: GLFW.Key -> Key
-fromGLFWkey (GLFW.CharKey 'A') = KEY_A
-fromGLFWkey (GLFW.CharKey 'B') = KEY_B
-fromGLFWkey (GLFW.CharKey 'C') = KEY_C
-fromGLFWkey (GLFW.CharKey 'D') = KEY_D
-fromGLFWkey (GLFW.CharKey 'E') = KEY_E
-fromGLFWkey (GLFW.CharKey 'F') = KEY_F
-fromGLFWkey (GLFW.CharKey 'G') = KEY_G
-fromGLFWkey (GLFW.CharKey 'H') = KEY_H
-fromGLFWkey (GLFW.CharKey 'I') = KEY_I
-fromGLFWkey (GLFW.CharKey 'J') = KEY_J
-fromGLFWkey (GLFW.CharKey 'K') = KEY_K
-fromGLFWkey (GLFW.CharKey 'L') = KEY_L
-fromGLFWkey (GLFW.CharKey 'M') = KEY_M
-fromGLFWkey (GLFW.CharKey 'N') = KEY_N
-fromGLFWkey (GLFW.CharKey 'O') = KEY_O
-fromGLFWkey (GLFW.CharKey 'P') = KEY_P
-fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q
-fromGLFWkey (GLFW.CharKey 'R') = KEY_R
-fromGLFWkey (GLFW.CharKey 'S') = KEY_S
-fromGLFWkey (GLFW.CharKey 'T') = KEY_T
-fromGLFWkey (GLFW.CharKey 'U') = KEY_U
-fromGLFWkey (GLFW.CharKey 'V') = KEY_V
-fromGLFWkey (GLFW.CharKey 'W') = KEY_W
-fromGLFWkey (GLFW.CharKey 'X') = KEY_X
-fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y
-fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z
-fromGLFWkey (GLFW.CharKey '0') = KEY_0
-fromGLFWkey (GLFW.CharKey '1') = KEY_1
-fromGLFWkey (GLFW.CharKey '2') = KEY_2
-fromGLFWkey (GLFW.CharKey '3') = KEY_3
-fromGLFWkey (GLFW.CharKey '4') = KEY_4
-fromGLFWkey (GLFW.CharKey '5') = KEY_5
-fromGLFWkey (GLFW.CharKey '6') = KEY_6
-fromGLFWkey (GLFW.CharKey '7') = KEY_7
-fromGLFWkey (GLFW.CharKey '8') = KEY_8
-fromGLFWkey (GLFW.CharKey '9') = KEY_9
-fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE
-fromGLFWkey (GLFW.SpecialKey GLFW.F1)  = KEY_F1
-fromGLFWkey (GLFW.SpecialKey GLFW.F2)  = KEY_F2
-fromGLFWkey (GLFW.SpecialKey GLFW.F3)  = KEY_F3
-fromGLFWkey (GLFW.SpecialKey GLFW.F4)  = KEY_F4
-fromGLFWkey (GLFW.SpecialKey GLFW.F5)  = KEY_F5
-fromGLFWkey (GLFW.SpecialKey GLFW.F6)  = KEY_F6
-fromGLFWkey (GLFW.SpecialKey GLFW.F7)  = KEY_F7
-fromGLFWkey (GLFW.SpecialKey GLFW.F8)  = KEY_F8
-fromGLFWkey (GLFW.SpecialKey GLFW.F9)  = KEY_F9
-fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10
-fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11
-fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12
-fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC
-fromGLFWkey (GLFW.SpecialKey GLFW.UP)    = KEY_UP
-fromGLFWkey (GLFW.SpecialKey GLFW.DOWN)  = KEY_DOWN
-fromGLFWkey (GLFW.SpecialKey GLFW.LEFT)  = KEY_LEFT
-fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT
+fromGLFWkey GLFW.Key'A = KEY_A
+fromGLFWkey GLFW.Key'B = KEY_B
+fromGLFWkey GLFW.Key'C = KEY_C
+fromGLFWkey GLFW.Key'D = KEY_D
+fromGLFWkey GLFW.Key'E = KEY_E
+fromGLFWkey GLFW.Key'F = KEY_F
+fromGLFWkey GLFW.Key'G = KEY_G
+fromGLFWkey GLFW.Key'H = KEY_H
+fromGLFWkey GLFW.Key'I = KEY_I
+fromGLFWkey GLFW.Key'J = KEY_J
+fromGLFWkey GLFW.Key'K = KEY_K
+fromGLFWkey GLFW.Key'L = KEY_L
+fromGLFWkey GLFW.Key'M = KEY_M
+fromGLFWkey GLFW.Key'N = KEY_N
+fromGLFWkey GLFW.Key'O = KEY_O
+fromGLFWkey GLFW.Key'P = KEY_P
+fromGLFWkey GLFW.Key'Q = KEY_Q
+fromGLFWkey GLFW.Key'R = KEY_R
+fromGLFWkey GLFW.Key'S = KEY_S
+fromGLFWkey GLFW.Key'T = KEY_T
+fromGLFWkey GLFW.Key'U = KEY_U
+fromGLFWkey GLFW.Key'V = KEY_V
+fromGLFWkey GLFW.Key'W = KEY_W
+fromGLFWkey GLFW.Key'X = KEY_X
+fromGLFWkey GLFW.Key'Y = KEY_Y
+fromGLFWkey GLFW.Key'Z = KEY_Z
+fromGLFWkey GLFW.Key'0 = KEY_0
+fromGLFWkey GLFW.Key'1 = KEY_1
+fromGLFWkey GLFW.Key'2 = KEY_2
+fromGLFWkey GLFW.Key'3 = KEY_3
+fromGLFWkey GLFW.Key'4 = KEY_4
+fromGLFWkey GLFW.Key'5 = KEY_5
+fromGLFWkey GLFW.Key'6 = KEY_6
+fromGLFWkey GLFW.Key'7 = KEY_7
+fromGLFWkey GLFW.Key'8 = KEY_8
+fromGLFWkey GLFW.Key'9 = KEY_9
+fromGLFWkey GLFW.Key'Space = KEY_SPACE
+fromGLFWkey GLFW.Key'F1 = KEY_F1
+fromGLFWkey GLFW.Key'F2 = KEY_F2
+fromGLFWkey GLFW.Key'F3 = KEY_F3
+fromGLFWkey GLFW.Key'F4 = KEY_F4
+fromGLFWkey GLFW.Key'F5 = KEY_F5
+fromGLFWkey GLFW.Key'F6 = KEY_F6
+fromGLFWkey GLFW.Key'F7 = KEY_F7
+fromGLFWkey GLFW.Key'F8 = KEY_F8
+fromGLFWkey GLFW.Key'F9 = KEY_F9
+fromGLFWkey GLFW.Key'F10 = KEY_F10
+fromGLFWkey GLFW.Key'F11 = KEY_F11
+fromGLFWkey GLFW.Key'F12 = KEY_F12
+fromGLFWkey GLFW.Key'Escape = KEY_ESC
+fromGLFWkey GLFW.Key'Up = KEY_UP
+fromGLFWkey GLFW.Key'Down = KEY_DOWN
+fromGLFWkey GLFW.Key'Left = KEY_LEFT
+fromGLFWkey GLFW.Key'Right = KEY_RIGHT
 fromGLFWkey _ = KEY_UNKNOWN
 
+-- https://www.glfw.org/docs/3.3/group__buttons.html
 fromGLFWbutton :: GLFW.MouseButton -> MouseButton
-fromGLFWbutton GLFW.ButtonLeft   = LMB
-fromGLFWbutton GLFW.ButtonRight  = RMB
-fromGLFWbutton GLFW.ButtonMiddle = MMB
+fromGLFWbutton GLFW.MouseButton'1 = LMB
+fromGLFWbutton GLFW.MouseButton'2 = RMB
+fromGLFWbutton GLFW.MouseButton'3 = MMB
 
 toGLFWkey :: Key -> GLFW.Key
-toGLFWkey KEY_A = GLFW.CharKey 'A'
-toGLFWkey KEY_B = GLFW.CharKey 'B'
-toGLFWkey KEY_C = GLFW.CharKey 'C'
-toGLFWkey KEY_D = GLFW.CharKey 'D'
-toGLFWkey KEY_E = GLFW.CharKey 'E'
-toGLFWkey KEY_F = GLFW.CharKey 'F'
-toGLFWkey KEY_G = GLFW.CharKey 'G'
-toGLFWkey KEY_H = GLFW.CharKey 'H'
-toGLFWkey KEY_I = GLFW.CharKey 'I'
-toGLFWkey KEY_J = GLFW.CharKey 'J'
-toGLFWkey KEY_K = GLFW.CharKey 'K'
-toGLFWkey KEY_L = GLFW.CharKey 'L'
-toGLFWkey KEY_M = GLFW.CharKey 'M'
-toGLFWkey KEY_N = GLFW.CharKey 'N'
-toGLFWkey KEY_O = GLFW.CharKey 'O'
-toGLFWkey KEY_P = GLFW.CharKey 'P'
-toGLFWkey KEY_Q = GLFW.CharKey 'Q'
-toGLFWkey KEY_R = GLFW.CharKey 'R'
-toGLFWkey KEY_S = GLFW.CharKey 'S'
-toGLFWkey KEY_T = GLFW.CharKey 'T'
-toGLFWkey KEY_U = GLFW.CharKey 'U'
-toGLFWkey KEY_V = GLFW.CharKey 'V'
-toGLFWkey KEY_W = GLFW.CharKey 'W'
-toGLFWkey KEY_X = GLFW.CharKey 'X'
-toGLFWkey KEY_Y = GLFW.CharKey 'Y'
-toGLFWkey KEY_Z = GLFW.CharKey 'Z'
-toGLFWkey KEY_0 = GLFW.CharKey '0'
-toGLFWkey KEY_1 = GLFW.CharKey '1'
-toGLFWkey KEY_2 = GLFW.CharKey '2'
-toGLFWkey KEY_3 = GLFW.CharKey '3'
-toGLFWkey KEY_4 = GLFW.CharKey '4'
-toGLFWkey KEY_5 = GLFW.CharKey '5'
-toGLFWkey KEY_6 = GLFW.CharKey '6'
-toGLFWkey KEY_7 = GLFW.CharKey '7'
-toGLFWkey KEY_8 = GLFW.CharKey '8'
-toGLFWkey KEY_9 = GLFW.CharKey '9'
-toGLFWkey KEY_SPACE = GLFW.CharKey ' '
-toGLFWkey KEY_F1 = GLFW.SpecialKey GLFW.F1
-toGLFWkey KEY_F2 = GLFW.SpecialKey GLFW.F2
-toGLFWkey KEY_F3 = GLFW.SpecialKey GLFW.F3
-toGLFWkey KEY_F4 = GLFW.SpecialKey GLFW.F4
-toGLFWkey KEY_F5 = GLFW.SpecialKey GLFW.F5
-toGLFWkey KEY_F6 = GLFW.SpecialKey GLFW.F6
-toGLFWkey KEY_F7 = GLFW.SpecialKey GLFW.F7
-toGLFWkey KEY_F8 = GLFW.SpecialKey GLFW.F8
-toGLFWkey KEY_F9 = GLFW.SpecialKey GLFW.F9
-toGLFWkey KEY_F10 = GLFW.SpecialKey GLFW.F10
-toGLFWkey KEY_F11 = GLFW.SpecialKey GLFW.F11
-toGLFWkey KEY_F12 = GLFW.SpecialKey GLFW.F12
-toGLFWkey KEY_ESC = GLFW.SpecialKey GLFW.ESC
-toGLFWkey KEY_UP    = GLFW.SpecialKey GLFW.UP
-toGLFWkey KEY_DOWN  = GLFW.SpecialKey GLFW.DOWN
-toGLFWkey KEY_LEFT  = GLFW.SpecialKey GLFW.LEFT
-toGLFWkey KEY_RIGHT = GLFW.SpecialKey GLFW.RIGHT
-toGLFWkey KEY_UNKNOWN = GLFW.SpecialKey GLFW.UNKNOWN
-
+toGLFWkey KEY_A = GLFW.Key'A
+toGLFWkey KEY_B = GLFW.Key'B
+toGLFWkey KEY_C = GLFW.Key'C
+toGLFWkey KEY_D = GLFW.Key'D
+toGLFWkey KEY_E = GLFW.Key'E
+toGLFWkey KEY_F = GLFW.Key'F
+toGLFWkey KEY_G = GLFW.Key'G
+toGLFWkey KEY_H = GLFW.Key'H
+toGLFWkey KEY_I = GLFW.Key'I
+toGLFWkey KEY_J = GLFW.Key'J
+toGLFWkey KEY_K = GLFW.Key'K
+toGLFWkey KEY_L = GLFW.Key'L
+toGLFWkey KEY_M = GLFW.Key'M
+toGLFWkey KEY_N = GLFW.Key'N
+toGLFWkey KEY_O = GLFW.Key'O
+toGLFWkey KEY_P = GLFW.Key'P
+toGLFWkey KEY_Q = GLFW.Key'Q
+toGLFWkey KEY_R = GLFW.Key'R
+toGLFWkey KEY_S = GLFW.Key'S
+toGLFWkey KEY_T = GLFW.Key'T
+toGLFWkey KEY_U = GLFW.Key'U
+toGLFWkey KEY_V = GLFW.Key'V
+toGLFWkey KEY_W = GLFW.Key'W
+toGLFWkey KEY_X = GLFW.Key'X
+toGLFWkey KEY_Y = GLFW.Key'Y
+toGLFWkey KEY_Z = GLFW.Key'Z
+toGLFWkey KEY_0 = GLFW.Key'0
+toGLFWkey KEY_1 = GLFW.Key'1
+toGLFWkey KEY_2 = GLFW.Key'2
+toGLFWkey KEY_3 = GLFW.Key'3
+toGLFWkey KEY_4 = GLFW.Key'4
+toGLFWkey KEY_5 = GLFW.Key'5
+toGLFWkey KEY_6 = GLFW.Key'6
+toGLFWkey KEY_7 = GLFW.Key'7
+toGLFWkey KEY_8 = GLFW.Key'8
+toGLFWkey KEY_9 = GLFW.Key'9
+toGLFWkey KEY_SPACE = GLFW.Key'Space
+toGLFWkey KEY_F1 = GLFW.Key'F1
+toGLFWkey KEY_F2 = GLFW.Key'F2
+toGLFWkey KEY_F3 = GLFW.Key'F3
+toGLFWkey KEY_F4 = GLFW.Key'F4
+toGLFWkey KEY_F5 = GLFW.Key'F5
+toGLFWkey KEY_F6 = GLFW.Key'F6
+toGLFWkey KEY_F7 = GLFW.Key'F7
+toGLFWkey KEY_F8 = GLFW.Key'F8
+toGLFWkey KEY_F9 = GLFW.Key'F9
+toGLFWkey KEY_F10 = GLFW.Key'F10
+toGLFWkey KEY_F11 = GLFW.Key'F11
+toGLFWkey KEY_F12 = GLFW.Key'F12
+toGLFWkey KEY_ESC = GLFW.Key'Escape
+toGLFWkey KEY_UP = GLFW.Key'Up
+toGLFWkey KEY_DOWN = GLFW.Key'Down
+toGLFWkey KEY_LEFT = GLFW.Key'Left
+toGLFWkey KEY_RIGHT = GLFW.Key'Right
+toGLFWkey KEY_UNKNOWN = GLFW.Key'Unknown
+
+-- https://www.glfw.org/docs/3.3/group__buttons.html
 toGLFWbutton :: MouseButton -> GLFW.MouseButton
-toGLFWbutton LMB = GLFW.ButtonLeft
-toGLFWbutton RMB = GLFW.ButtonRight
-toGLFWbutton MMB = GLFW.ButtonMiddle
+toGLFWbutton LMB = GLFW.MouseButton'1
+toGLFWbutton RMB = GLFW.MouseButton'2
+toGLFWbutton MMB = GLFW.MouseButton'3
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
index d0664b7..3563c30 100644
--- a/demos/pong/Main.hs
+++ b/demos/pong/Main.hs
@@ -1,79 +1,82 @@
 module Main where
 
+import Data.Maybe (mapMaybe)
+import Graphics.Rendering.OpenGL.GL (($=))
+import qualified Graphics.Rendering.OpenGL.GL as GL
 import Pong
-
+import Spear.Game
 import Spear.Math.AABB
 import Spear.Math.Spatial2
 import Spear.Math.Vector
-import Spear.Game
 import Spear.Window
 
-import Data.Maybe (mapMaybe)
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import Graphics.Rendering.OpenGL.GL (($=))
-
 data GameState = GameState
-     { wnd     :: Window
-     , world   :: [GameObject]
-     }
+  { window :: Window,
+    world :: [GameObject]
+  }
 
-main = run
-     $ withWindow (640,480) [] Window (2,0) (Just "Pong") initGame
-     $ loop (Just 30) step
+main =
+  withWindow (900, 600) (2, 0) (Just "Pong") initGame $
+    loop step
 
-initGame wnd = do
-         gameIO $ do
-                GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
-                GL.matrixMode $= GL.Modelview 0
-                GL.loadIdentity
-         return $ GameState wnd newWorld
+initGame :: Window -> Game () GameState
+initGame window = do
+  gameIO $ do
+    GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
+    GL.matrixMode $= GL.Modelview 0
+    GL.loadIdentity
+  return $ GameState window newWorld
 
 step :: Elapsed -> Dt -> Game GameState Bool
 step elapsed dt = do
-     gs <- getGameState
-     evts <- events (wnd gs)
-     gameIO . process $ evts
-     let evts' = translate evts
-     modifyGameState $ \ gs -> gs
-                     { world = stepWorld elapsed dt evts' (world gs) }
-     getGameState >>= \gs -> gameIO . render $ world gs
-     return (not $ exitRequested evts)
+  --gameIO $ putStrLn "Tick"
+  gs <- getGameState
+  evts <- events (window gs)
+  gameIO . process $ evts
+  let evts' = translate evts
+  modifyGameState $ \gs ->
+    gs
+      { world = stepWorld elapsed dt evts' (world gs)
+      }
+  getGameState >>= \gs -> gameIO . render $ world gs
+  return (not $ exitRequested evts)
 
 render world = do
-       GL.clear [GL.ColorBuffer]
-       mapM_ renderGO world
-       swapBuffers
+  GL.clear [GL.ColorBuffer]
+  mapM_ renderGO world
 
 renderGO :: GameObject -> IO ()
 renderGO go = do
-         let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
-             (Vector2 xcenter ycenter) = pos go
-             (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
-         GL.preservingMatrix $ do
-            GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
-            GL.renderPrimitive (GL.TriangleStrip) $ do
-               GL.vertex (GL.Vertex2 xmin ymax)
-               GL.vertex (GL.Vertex2 xmin ymin)
-               GL.vertex (GL.Vertex2 xmax ymax)
-               GL.vertex (GL.Vertex2 xmax ymin)
+  let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
+      (Vector2 xcenter ycenter) = pos go
+      (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
+  GL.preservingMatrix $ do
+    GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
+    GL.renderPrimitive (GL.TriangleStrip) $ do
+      GL.vertex (GL.Vertex2 xmin ymax)
+      GL.vertex (GL.Vertex2 xmin ymin)
+      GL.vertex (GL.Vertex2 xmax ymax)
+      GL.vertex (GL.Vertex2 xmax ymin)
 
 process = mapM_ procEvent
+
 procEvent (Resize w h) = do
-          GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
-          GL.matrixMode $= GL.Projection
-          GL.loadIdentity
-          GL.ortho 0 1 0 1 (-1) 1
-          GL.matrixMode $= GL.Modelview 0
+  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
+  GL.matrixMode $= GL.Projection
+  GL.loadIdentity
+  GL.ortho 0 1 0 1 (-1) 1
+  GL.matrixMode $= GL.Modelview 0
 procEvent _ = return ()
 
 translate = mapMaybe translate'
-translate' (KeyDown KEY_LEFT)  = Just MoveLeft
+
+translate' (KeyDown KEY_LEFT) = Just MoveLeft
 translate' (KeyDown KEY_RIGHT) = Just MoveRight
-translate' (KeyUp   KEY_LEFT)  = Just StopLeft
-translate' (KeyUp   KEY_RIGHT) = Just StopRight
+translate' (KeyUp KEY_LEFT) = Just StopLeft
+translate' (KeyUp KEY_RIGHT) = Just StopRight
 translate' _ = Nothing
 
-exitRequested = any (==(KeyDown KEY_ESC))
+exitRequested = any (== (KeyDown KEY_ESC))
 
 f2d :: Float -> GL.GLdouble
 f2d = realToFrac
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
index 1761823..232c69a 100644
--- a/demos/pong/Pong.hs
+++ b/demos/pong/Pong.hs
@@ -1,66 +1,64 @@
 module Pong
-(
-    GameEvent(..)
-,   GameObject
-,   newWorld
-,   stepWorld
-,   aabb
-)
+  ( GameEvent (..),
+    GameObject,
+    newWorld,
+    stepWorld,
+    aabb,
+  )
 where
 
+import Data.Monoid (mconcat)
+import GHC.Float (double2Float)
 import Spear.Math.AABB
 import Spear.Math.Spatial2
 import Spear.Math.Vector
 import Spear.Step
 
-import Data.Monoid (mconcat)
-import GHC.Float (double2Float)
-
 -- Game events
 
 data GameEvent
-     = MoveLeft
-     | MoveRight
-     | StopLeft
-     | StopRight
-     deriving (Eq, Ord)
+  = MoveLeft
+  | MoveRight
+  | StopLeft
+  | StopRight
+  deriving (Eq, Ord)
 
 -- Game objects
 
 data GameObject = GameObject
-     { aabb   :: AABB2
-     , obj    :: Obj2
-     , gostep :: Step [GameObject] [GameEvent] GameObject GameObject
-     }
+  { aabb :: AABB2,
+    obj :: Obj2,
+    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
+  }
 
 instance Spatial2 GameObject where
-         getObj2 = obj
-         setObj2 s o = s { obj = o }
+  getObj2 = obj
+  setObj2 s o = s {obj = o}
 
 stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
 stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
 
 update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
 update elapsed dt evts gos go =
-       let (go', s') = runStep (gostep go) elapsed dt gos evts go
-       in go' { gostep = s' }
+  let (go', s') = runStep (gostep go) elapsed dt gos evts go
+   in go' {gostep = s'}
 
 ballBox :: AABB2
-ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01
+ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01
 
 padSize = vec2 0.05 0.02
 
-padBox = AABB2 (-padSize) padSize
+padBox = AABB2 (- padSize) padSize
 
 obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
 
 ballVelocity = Vector2 0.3 0.3
 
 newWorld =
-         [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity
-         , GameObject padBox  (obj2 0.5 0.9) stepEnemy
-         , GameObject padBox  (obj2 0.5 0.1) stepPlayer
-         ]
+  [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity,
+    GameObject padBox (obj2 0.5 0.9) stepEnemy,
+    GameObject padBox (obj2 0.5 0.1) stepPlayer
+  ]
 
 -- Ball steppers
 
@@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall
 
 collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
 collideBall vel = step $ \_ _ gos _ ball ->
-            let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
-                collideCol = x pmin < 0 || x pmax > 1
-                collideRow = y pmin < 0 || y pmax > 1
-                           || any (collide ball) (tail gos)
-                negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v
-                negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v
-                vel' = negx . negy $ vel
-            in ((vel', ball), collideBall vel')
+  let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
+      collideCol = x pmin < 0 || x pmax > 1
+      collideRow =
+        y pmin < 0 || y pmax > 1
+          || any (collide ball) (tail gos)
+      negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v
+      negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v
+      vel' = negx . negy $ vel
+   in ((vel', ball), collideBall vel')
 
 collide go1 go2 =
-        let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1))
-                   = aabb go1 `aabbAdd` pos go1
-            (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2))
-                   = aabb go2 `aabbAdd` pos go2
-        in not $  xmax1 < xmin2 || xmin1 > xmax2
-               || ymax1 < ymin2 || ymin1 > ymax2
+  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
+        aabb go1 `aabbAdd` pos go1
+      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
+        aabb go2 `aabbAdd` pos go2
+   in not $
+        xmax1 < xmin2 || xmin1 > xmax2
+          || ymax1 < ymin2
+          || ymin1 > ymax2
 
-aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax)
+aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
 
 moveBall :: Step s e (Vector2, GameObject) GameObject
-moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall)
+moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
 
 -- Enemy stepper
 
@@ -96,32 +97,34 @@ stepEnemy = movePad
 
 movePad :: Step s e GameObject GameObject
 movePad = step $ \elapsed _ _ _ pad ->
-        let p  = vec2 px 0.9
-            px = double2Float (sin elapsed * 0.5 + 0.5)
-               * (1 - 2 * x padSize)
-               + x padSize
-        in (setPos p pad, movePad)
+  let p = vec2 px 0.9
+      px =
+        double2Float (sin elapsed * 0.5 + 0.5)
+          * (1 - 2 * x padSize)
+          + x padSize
+   in (setPos p pad, movePad)
 
 -- Player stepper
 
 stepPlayer = sfold moveGO .> clamp
 
-moveGO = mconcat
-       [ switch StopLeft  sid MoveLeft  (moveGO' $ vec2 (-1) 0)
-       , switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
-       ]
+moveGO =
+  mconcat
+    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0),
+      switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
+    ]
 
 moveGO' :: Vector2 -> Step s e GameObject GameObject
 moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
 
 clamp :: Step s e GameObject GameObject
 clamp = spure $ \go ->
-      let p' = vec2 (clamp' x s (1 - s)) y
-          (Vector2 x y) = pos go
-          clamp' x a b = if x < a then a else if x > b then b else x
-          (Vector2 s _) = padSize
-      in setPos p' go
+  let p' = vec2 (clamp' x s (1 - s)) y
+      (Vector2 x y) = pos go
+      clamp' x a b = if x < a then a else if x > b then b else x
+      (Vector2 s _) = padSize
+   in setPos p' go
 
-toDir True MoveLeft  = vec2 (-1) 0
+toDir True MoveLeft = vec2 (-1) 0
 toDir True MoveRight = vec2 1 0
-toDir _ _ = vec2 0 0
\ No newline at end of file
+toDir _ _ = vec2 0 0
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs
index 9a994af..e8ef27d 100644
--- a/demos/pong/Setup.hs
+++ b/demos/pong/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+
 main = defaultMain
diff --git a/demos/pong/cabal.project b/demos/pong/cabal.project
new file mode 100644
index 0000000..3dc1fca
--- /dev/null
+++ b/demos/pong/cabal.project
@@ -0,0 +1,2 @@
+packages: .
+          ../../
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal
index bebedb9..23ada51 100644
--- a/demos/pong/pong.cabal
+++ b/demos/pong/pong.cabal
@@ -1,15 +1,15 @@
--- Initial pong.cabal generated by cabal init.  For further documentation, 
+-- Initial pong.cabal generated by cabal init.  For further documentation,
 -- see http://haskell.org/cabal/users-guide/
 
 name:                pong
 version:             0.1.0.0
 synopsis:            A pong clone
--- description:         
+-- description:
 license:             BSD3
 license-file:        LICENSE
 author:              Marc Sunet
--- maintainer:          
--- copyright:           
+-- maintainer:
+-- copyright:
 category:            Game
 build-type:          Simple
 cabal-version:       >=1.8
@@ -17,5 +17,5 @@ cabal-version:       >=1.8
 executable pong
   -- hs-source-dirs:      src
   main-is:             Main.hs
-  -- other-modules:       
-  build-depends:       base ==4.6.*, Spear, OpenGL
+  -- other-modules:
+  build-depends:       base, Spear, OpenGL
-- 
cgit v1.2.3