Streamling the Game monad, use MonadIO for automatic lifting.

1 files changed, 35 insertions, 27 deletions

diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index f77136f..eafa983 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Main where
 
 import           Pong
@@ -21,15 +23,16 @@ import           Control.Monad              (when)
 import           Data.Maybe                 (mapMaybe)
 
 
-data GameState = GameState
-  { context         :: AppContext
-  , renderCoreState :: RenderCoreState
-  , immRenderState  :: ImmRenderState
+data Pong = Pong
+  { immRenderState  :: ImmRenderState
   , viewProjection  :: Matrix4
   , backgroundMusic :: SoundSource
   , world           :: [GameObject]
   }
 
+type GameState = AppState Pong
+
+
 options = defaultAppOptions { title = "Pong" }
 
 app = App options initGame endGame step render resize
@@ -38,32 +41,38 @@ app = App options initGame endGame step render resize
 main :: IO ()
 main = runApp app
 
-initGame :: AppContext -> Game () GameState
-initGame context = do
-  (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
-  (music, soundState') <- flip runSiblingGame (appSoundState context) $ do
+initGame :: Game AppContext Pong
+initGame = do
+  renderCoreState <- contextRenderCoreState <$> get
+  (immRenderState, renderCoreState') <- runSiblingGame renderCoreState newImmRenderer
+  -- TODO: This can work if we use FlexibleContexts and change the function signatures.
+  --immRenderState <- newImmRenderer
+  music <- siblingGame $ do
     musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav"
     music <- makeSoundSource
-    liftIO $ do
-      setSoundSourceBuffer music musicBuffer
-      setSoundLoopMode music Loop
-      playSounds [music]
+    -- TODO: setSoundSourceBuffer generates an AL error for some reason, though
+    -- the music still plays.
+    -- "user error (runALUT: There was already an AL error on entry to an ALUT function)"
+    setSoundSourceBuffer music musicBuffer
+    setSoundLoopMode music Loop
+    playSounds [music]
     return music
-  let context' = context { appSoundState = soundState' }
-  return $ GameState context' renderCoreState immRenderState Matrix4.id music newWorld
+  return $ Pong immRenderState Matrix4.id music newWorld
 
 endGame :: Game GameState ()
 endGame = do
-  game <- get
-  runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
+  renderCoreState <- appRenderCoreState <$> get
+  game <- getGameState
+  exec' runSiblingGame renderCoreState (deleteImmRenderer $ immRenderState game)
 
 
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
-  gameState <- get
-  events <- processInput (appWindow . context $ gameState)
+  appState  <- get
+  gameState <- getGameState
+  events    <- processInput (appWindow appState)
   --when (events /= []) $ liftIO . putStrLn $ show events
-  modify $ \gameState -> gameState
+  modifyGameState $ \pong -> pong
     { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState)
     }
   return (not $ exitRequested inputEvents)
@@ -79,18 +88,17 @@ exitRequested = elem (KeyDown KEY_ESC)
 
 render :: Game GameState ()
 render = do
-  gameState <- get
-  immRenderState' <- flip execSubGame (immRenderState gameState) $ do
+  gameState <- getGameState
+  immRenderState' <- exec runSiblingGame (immRenderState gameState) $ do
     immStart
     immSetViewProjectionMatrix (viewProjection gameState)
     -- Clear the background to a different colour than the playable area to make
     -- the latter distinguishable.
-    liftIO $ do
-      setClearColour (0.2, 0.2, 0.2, 0.0)
-      clearBuffers [ColourBuffer]
+    setClearColour (0.2, 0.2, 0.2, 0.0)
+    clearBuffers [ColourBuffer]
     render' $ world gameState
     immEnd
-  put $ gameState { immRenderState = immRenderState' }
+  putGameState $ gameState { immRenderState = immRenderState' }
 
 render' :: [GameObject] -> Game ImmRenderState ()
 render' world = do
@@ -132,7 +140,7 @@ resize (ResizeEvent w h) =
       bottom = if r > 1 then 0 else -pad
       top    = if r > 1 then 1 else 1 + pad
   in do
-    liftIO $ setViewport 0 0 w h
-    modify $ \state -> state {
+    setViewport 0 0 w h
+    modifyGameState $ \pong -> pong {
       viewProjection = Matrix4.ortho left right bottom top (-1) 1
     }