Rotate a square in Haskell GLUT

gistfile1.hs

module Main where

-- http://www.f13g.com/%A5%D7%A5%ED%A5%B0%A5%E9%A5%DF%A5%F3%A5%B0/Haskell/GLUT/#content_1_0

import qualified Control.Monad.State as S
import Graphics.UI.GLUT

type AngleState a = S.StateT GLdouble IO a

timeOut :: Timeout
timeOut = 40

initialAngle :: GLdouble
initialAngle = 0.0

diffAngle :: GLdouble
diffAngle = 14.4

main :: IO ()
main = getArgsAndInitialize
       >> createWindow "GuruGuru"
       >> displayCallback
            $= S.evalStateT display initialAngle
       >> reshapeCallback
            $= Just reshape
       >> addTimerCallback timeOut
            (S.evalStateT timerProc initialAngle)
       >> mainLoop

display :: AngleState ()
display
  = S.liftIO preDisplay
    >> displayMatrix
    >> S.liftIO swapBuffers

preDisplay :: IO ()
preDisplay
  = clearColor $= Color4 0.0 0.0 0.0 0.0
    >> clear [ColorBuffer]
    >> loadIdentity

displayMatrix :: AngleState ()
displayMatrix
  = S.get >>=
    \r -> S.liftIO $ preservingMatrix $
          S.liftIO $ rotateMatrix r

rotateMatrix :: GLdouble -> IO ()
rotateMatrix r
  = rotate r (Vector3 0.0 0.0 1.0 :: Vector3 GLdouble)
    >> renderPrimitive Quads
         (mapM_ vertex [ Vertex3 0.10      0.10  0.0
                       , Vertex3 (-0.10)   0.10  0.0
                       , Vertex3 (-0.10) (-0.10) 0.0
                       , Vertex3 0.10    (-0.10) 0.0
                       :: Vertex3 GLfloat])

-- data Size = Size { width :: GLSizei, height :: GLSizei }
-- type ReshapeCallback = Size -> IO ()
reshape :: ReshapeCallback
reshape size@(Size w h)
  = viewport $= (Position 0 0, size)
    >> matrixMode $= Projection
    >> loadIdentity
    >> perspective 60.0
                   (fromIntegral w / fromIntegral h)
                   0.001 50.0
    >> lookAt (Vertex3 0.0 0.0 (-1.0))
              (Vertex3 0.0 0.0 0.0)
              (Vector3 0.0 1.0 0.0)

timerProc :: AngleState ()
timerProc
  = display >> S.modify (+ diffAngle) >>
    S.get >>=
    \r -> S.liftIO $ addTimerCallback timeOut
                   $ S.evalStateT timerProc r