Use OpenGL 3.2 shaders and GLUT in Haskell

main.hs

{-# LANGUAGE CPP #-}

-- it draws a triangle.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL
import Foreign.Marshal.Array
import Foreign.Storable
import Foreign.Ptr
import qualified Data.ByteString as B
import qualified Data.Text.Encoding as TE
import qualified Data.Text as T

colors = [1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0] :: [Float]
vertices = [-0.5, -0.5, 0.1, 0.5, -0.5, 0.1, -0.5, 0.5, 0.1] :: [Float]

checkError :: String -> IO ()
checkError functionName = get errors >>= mapM_ reportError
   where reportError e = 
            putStrLn (showError e ++ " detected in " ++ functionName)
         showError (Error category message) =
            "GL error " ++ show category ++ " (" ++ message ++ ")"

packUtf8 :: String -> B.ByteString
packUtf8 = TE.encodeUtf8 . T.pack

vertexShaderSource :: B.ByteString
vertexShaderSource = packUtf8 . unlines $ [
   "#version 130",
   "in vec4 v_pos, v_color;",
   "varying vec4 tx_color;",
   "void main()",
   "{",
   "   tx_color = v_color;",
   "   gl_Position = v_pos;",
   "}" ]

fragmentShaderSource :: B.ByteString
fragmentShaderSource = packUtf8 . unlines $ [
   "#version 130",
   "varying vec4 tx_color;",
   "void main()",
   "{",
   "   gl_FragColor = vec4(1.0, 1.0, 0.0, 1.0)-0.1*tx_color;",
   "}" ]

main :: IO ()
main = do
    (_progName, _args) <- getArgsAndInitialize
    _window <- createWindow "Hello World"
    initialContextVersion $= (3, 2)
    initialDisplayMode $= [ RGBAMode ]
    initialContextProfile $= [ CoreProfile ]
    initCallbacks
    mainLoop

initCallbacks = do
  frag <- createShader FragmentShader
  vert <- createShader VertexShader
  prog <- createProgram

  checkError $ __FILE__ ++ " " ++ show __LINE__

  shaderSourceBS vert $= vertexShaderSource
  shaderSourceBS frag $= fragmentShaderSource

  checkError $ __FILE__ ++ " " ++ show __LINE__

  compileShader vert
  checkError $ __FILE__ ++ " " ++ show __LINE__

  compileShader frag
  checkError $ __FILE__ ++ " " ++ show __LINE__

  attachedShaders prog $= [vert, frag]

  linkProgram prog
  putStrLn =<< get (programInfoLog prog)
  checkError $ __FILE__ ++ " " ++ show __LINE__

  vertexIndex <- get (attribLocation prog "v_pos")
  checkError $ __FILE__ ++ " " ++ show __LINE__

  vertexAttribArray vertexIndex $= Enabled
  checkError $ __FILE__ ++ " " ++ show __LINE__

  colorIndex <- get (attribLocation prog "v_color")
  checkError $ __FILE__ ++ " " ++ show __LINE__

  vertexAttribArray colorIndex $= Enabled
  checkError $ __FILE__ ++ " " ++ show __LINE__


  reshapeCallback $= Just (reshape prog)
  checkError $ __FILE__ ++ " " ++ show __LINE__
  displayCallback $= (display prog (vertexIndex, colorIndex))
  checkError $ __FILE__ ++ " " ++ show __LINE__

display :: Program -> (AttribLocation, AttribLocation) -> DisplayCallback
display prog (posLoc, colorLoc) = do
    checkError $ __FILE__ ++ " " ++ show __LINE__

    clearColor $= Color4 0.0 1.0 1.0 1.0
    clear [ ColorBuffer ]

    checkError $ __FILE__ ++ " " ++ show __LINE__
    currentProgram $= Just prog

    checkError $ __FILE__ ++ " " ++ show __LINE__
    vboColor <- genObjectName
    vboPos <- genObjectName

    checkError $ __FILE__ ++ " " ++ show __LINE__
    bindBuffer ArrayBuffer $= Just vboColor
    withArray colors $ \buffer ->
      bufferData ArrayBuffer $= (fromIntegral $ (length colors)*sizeOf(0::Float), buffer, StaticDraw)

    checkError $ __FILE__ ++ " " ++ show __LINE__
    bindBuffer ArrayBuffer $= Just vboPos
    withArray vertices $ \buffer ->
      bufferData ArrayBuffer $= (fromIntegral $ (length vertices)*sizeOf(0::Float), buffer, StaticDraw)

    checkError $ __FILE__ ++ " " ++ show __LINE__

    bindBuffer ArrayBuffer $= Just vboColor
    vertexAttribPointer colorLoc $=
      (ToFloat, (VertexArrayDescriptor 4 Float (fromIntegral $ 4*sizeOf(0::Float)) nullPtr))

    checkError $ __FILE__ ++ " " ++ show __LINE__

    bindBuffer ArrayBuffer $= Just vboPos
    vertexAttribPointer posLoc $=
      (ToFloat, (VertexArrayDescriptor 3 Float (fromIntegral $ 3*sizeOf(0::Float)) nullPtr))

    checkError $ __FILE__ ++ " " ++ show __LINE__

    checkError $ __FILE__ ++ " " ++ show __LINE__

    drawArrays Triangles 0 3

    checkError $ __FILE__ ++ " " ++ show __LINE__

    flush

    checkError $ __FILE__ ++ " " ++ show __LINE__

reshape :: Program -> ReshapeCallback
reshape shader = 
    \s@(Size width height) -> do
      viewport $= ((Position 0 0), s)
      postRedisplay Nothing