Slight extension of http://blog.sigfpe.com/2011/10/quick-and-dirty-reinversion-of-control.html, which adds input capabilities

glinv.hs

{--
This file is a slight extension of Sigfpe's "Quick and dirty reinversion of control":

http://blog.sigfpe.com/2011/10/quick-and-dirty-reinversion-of-control.html


I only added input capabilities: yieldInput + modification to yield
and of course the lines in imperative (i.e. our re-captured "main loop") which have to do with getting input.
--}

import Graphics.UI.GLUT
import Control.Monad.Cont


display :: GLdouble -> IO ()
display y = do
  clear [ColorBuffer]
  
  renderPrimitive LineStrip $ do
    vertex (Vertex2 (-1) (-y))
    vertex (Vertex2 1 y)

  swapBuffers
  postRedisplay Nothing



main = do
  (progname, _) <- getArgsAndInitialize
  initialWindowSize $= Size 500 500
  initialDisplayMode $= [DoubleBuffered, RGBMode]
  createWindow "Bounce!"

  matrixMode $= Modelview 0
  loadIdentity

  matrixMode $= Projection
  loadIdentity
  ortho (-1) 1 (-1) 1 (-1) 1

  imperative
  mainLoop


imperative = flip runContT return $ do
  liftIO $ print "Start!"

  forever $ do
    forM_ [-1, -0.992 .. 1.0] $ \y -> do
      render $ display y
      yield

    liftIO $ print "Bounce!"
    
    liftIO $ print "yielding for input now"
    (key, _, _, _) <- yieldInput
    liftIO $ putStrLn $ "user pressed: " ++ show key

    forM_ [-1, -0.992 .. 1.0] $ \y -> do
      render $ display (-y)
      yield

    liftIO $ print "Bounce!"
    yield


render f = liftIO $ displayCallback $= f

-- modified yield!
yield :: ContT () IO ()
yield = ContT $ \k -> do
  idleCallback $= Just (do
    idleCallback $= Nothing -- unhook
    k ()
    )

-- wait for input
yieldInput :: ContT () IO (Key, KeyState, Modifiers, Position)
yieldInput = do
  ContT $ \k -> do
    keyboardMouseCallback $= Just (
      \key state mod pos -> do
        keyboardMouseCallback $= Nothing -- unhook 
        k (key, state, mod, pos)
        )