reinversion of control, part 2

reinversion.2.hs

module Main where

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

import System.Exit                  ( exitSuccess )

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 [] $ \keys -> do
        print keys
        when (KeyEsc `elem` keys) $ void exitSuccess
        forever swapBuffers

rabbitHole :: [Key] -> ([Key] -> IO ()) -> IO ()
rabbitHole keys meanWhile = flip runContT return $ do
    -- This yield ends execution until the continuation is called by
    -- the key callback.
    keys' <- yieldInput keys meanWhile

    -- Continuation was called and now the computation completes and
    -- runs again due recursion
    liftIO $ rabbitHole keys' meanWhile

yieldInput :: [Key] -> ([Key] -> IO ()) -> ContT () IO [Key]
yieldInput keys 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
                                              in f $ if isPressed
                                                     then key:keys'
                                                     else keys'
    -- Execution loops here because our meanWhile ends in forever
    -- swapBuffers, which is probably giving us seizures.
    meanWhile keys