Game Monad for GLFW

Game.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Theorem.Core.Monad (
		TheoremT, Theorem, MonadTheorem(..),
		MonadIO(..),
		runTheorem
	) where

import Control.Monad (Monad)
import Control.Monad.RWS (RWST, MonadRWS)
import Control.Monad.Reader (ReaderT, MonadReader)
import Control.Monad.State (StateT, MonadState)
import Control.Monad.Trans (MonadIO(..), lift)
import Control.Monad.Writer (WriterT, MonadWriter)

import Control.Exception (bracket_)

import Data.Monoid (Monoid)

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.GLFW as GLFW

newtype TheoremT m a = Theorem (m a)
	deriving (Monad, MonadIO)

type Theorem a = TheoremT IO a

class (MonadIO m) => MonadTheorem m where
	liftTheorem :: Theorem a -> m a 

instance (MonadIO m) => MonadTheorem (TheoremT m) where
	liftTheorem (Theorem t) = liftIO t

instance (MonadTheorem m) => MonadTheorem (ReaderT r m) where
	liftTheorem = lift . liftTheorem

instance (MonadTheorem m) => MonadTheorem (StateT s m) where
	liftTheorem = lift . liftTheorem

instance (Monoid w, MonadTheorem m) => MonadTheorem (WriterT w m) where
	liftTheorem = lift . liftTheorem

instance (Monoid w, MonadTheorem m) => MonadTheorem (RWST r w s m) where
	liftTheorem = lift . liftTheorem

runTheorem :: (MonadIO m) => Int -> Int -> Theorem a -> m a
runTheorem w h (Theorem t) = liftIO $ bracket_ init (GLFW.closeWindow >> GLFW.terminate) t
	where init = do
		GLFW.initialize
		GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayAlphaBits 8] GLFW.Window
		GLFW.windowTitle $= "Theorem"
		GL.shadeModel    $= GL.Smooth