reinversion of control, part 3 - down the rabbit hole

reinversion.3.hs

module Main where

import Graphics.UI.GLFW
import Control.Monad.Cont

import System.Exit                  ( exitSuccess )

data GameState = GameState { keys :: [Key]
                           , wSize:: (Int, Int)
                           , mPos :: (Int, Int)
                           } deriving (Show, Eq)

type GameStateUpdater = GameState -> (GameState -> IO ()) -> ContT () IO GameState

initialGameState :: GameState
initialGameState = GameState [] (0,0) (0,0)


main :: IO ()
main = do
    putStrLn "Running glfw-cont-test."
    True <- initialize
    True <- openWindow defaultDisplayOptions

    -- Make sure GLFW quits for us if we close the window.
    setWindowCloseCallback exitSuccess

    -- Initiate our decent into the rabbit hole, tossing in
    -- our initial value of keys and our main loop.

    rabbitHole yieldWindowSize initialGameState $ \gs ->
        rabbitHole yieldInput gs $ \gs' ->
            rabbitHole yieldMosPos gs' $ \gs'' -> do
                when (KeyEsc `elem` keys gs'') (void exitSuccess)
                print gs''
                forever swapBuffers

--            print gs'
--            -- Execution loops here because our meanWhile ends in forever
--            -- swapBuffers, which is probably giving us seizures.
--            forever swapBuffers

rabbitHole :: GameStateUpdater -> GameState -> (GameState -> IO ()) -> IO ()
rabbitHole updater gs meanWhile = flip runContT return $ do
    -- This yield ends execution until the continuation is called by
    -- the key callback.
    gs' <- updater gs meanWhile
    -- Continuation was called and now the computation completes and
    -- runs again due recursion
    liftIO $ rabbitHole updater gs' meanWhile

yieldInput :: GameStateUpdater
yieldInput gs meanWhile = ContT $ \f -> do
    putStrLn "Setting key callback."
    -- Use re-inversion of control to continue the outer computation
    -- f with the new state of keys pressed, once a key is pressed or
    -- lifted.
    setKeyCallback $ \key isPressed -> let keys' = filter (/= key) $ keys gs
                                              in f $ if isPressed
                                                     then gs{keys=key:keys'}
                                                     else gs{keys=keys'}
    meanWhile gs

yieldWindowSize :: GameStateUpdater
yieldWindowSize gs meanWhile = ContT $ \f -> do
    putStrLn "Setting window size callback."
    -- Again use re-inversion of control to wait for input and
    -- trigger another climb down the rabbit hole with our new
    -- game state.
    setWindowSizeCallback $ \w h ->
        -- For some reason GLFW-b (and maybe GLFW) calls this callback
        -- immediately after it's set. This causes a recursion loop.
        -- So we check to see if it's actually changing here, but it
        -- doesn't work well. Sucks.
        when ((w,h) /= wSize gs) $ f gs{wSize=(w,h)}
    meanWhile gs

yieldMosPos :: GameStateUpdater
yieldMosPos gs meanWhile = ContT $ \f -> do
    putStrLn "Setting mouse position callback."
    setMousePositionCallback $ \x y ->
        when ((x,y) /= mPos gs) $ f $ gs{mPos=(x,y)}
    meanWhile gs