OpenGL from Haskell

2014-03-15*
haskell, opengl

The following is my translation/adaptation of tutorial #2 at http://www.opengl-tutorial.org. It draws a single red triangle on the screen with a dark blue background. It takes quite a bit of boilerplate code just to get something on the screen!

My version uses the code from https://github.com/YPares/Haskell-OpenGL3.1-Tutos, but does not use Control.Applicative and also does not put the shaders containing GLSL in a separate text file. Everything is self-contained in one file, and it only uses the PackageImports and RecordWildCards GHC extensions. The PackageImports is only necessary if you have both GLFW and GLFW-b Hackage packages installed in your system (as they have a name clash of Graphics.UI.GLFW, you need to disambiguate this import by specifying the package name). The RecordWildCards extension is pretty standard and exists purely for syntactic sugar (no type-level hoops and such) — if you don’t know about it you should google it.

I went ahead and added type signatures for all top-level functions — something that many Haskell tutorial writers hate doing for some strange, unknown reason.1 Also, I ran the code through ghc --make -Wall and silenced all warnings.

I hereby release it into the Public Domain. From what I can tell, YPares’s code doesn’t have a license… I think this should be OK.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
module Main where

import Control.Monad
import Data.Maybe
import Foreign
import Foreign.C.String
import Foreign.C.Types
import qualified "GLFW-b" Graphics.UI.GLFW as GLFW
import Graphics.Rendering.OpenGL.Raw
import System.Exit

data GLIDs = GLIDs
  { progId :: !GLuint
  , vertexArrayId :: !GLuint
  , vertexBufferId :: !GLuint
  }

withNewPtr :: Storable b => (Ptr b -> IO a) -> IO b
withNewPtr f = alloca (\p -> f p >> peek p)

initialize :: IO GLFW.Window
initialize = do
  ok <- GLFW.init
  when (not ok) $ do
    _ <- fail "Failed to initialize GLFW"
    exitFailure
  mapM_ GLFW.windowHint
    [ GLFW.WindowHint'Samples 4 -- 4x antialiasing
    , GLFW.WindowHint'ContextVersionMajor 3 -- OpenGL 3.3
    , GLFW.WindowHint'ContextVersionMinor 3
    -- we don't want the old OpenGL
    , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
    ]

  win <- GLFW.createWindow 800 600 "Window Title" Nothing Nothing
  when (isNothing win) $ do
    _ <- fail "Failed to create OpenGL window"
    GLFW.terminate
    exitFailure
  let
    win' = fromJust win
  GLFW.makeContextCurrent win

  GLFW.setStickyKeysInputMode win' GLFW.StickyKeysInputMode'Enabled

  return win'

initializeGL :: IO GLIDs
initializeGL = do
  glClearColor 0 0 0.4 0
  progId <- loadProgram vertexShader1 fragmentShader1
  vaId <- newVAO
  bufId <- fillNewBuffer vertexBufferData
  return $ GLIDs
    { progId = progId
    , vertexArrayId = vaId
    , vertexBufferId = bufId
    }

freeResources :: GLIDs -> IO ()
freeResources GLIDs{..} = do
  with vertexBufferId $ glDeleteBuffers 1
  with vertexArrayId $ glDeleteVertexArrays 1

newVAO :: IO GLuint
newVAO = do
  vaId <- withNewPtr (glGenVertexArrays 1)
  glBindVertexArray vaId
  return vaId

fillNewBuffer :: [GLfloat] -> IO GLuint
fillNewBuffer xs = do
  bufId <- withNewPtr (glGenBuffers 1)
  glBindBuffer gl_ARRAY_BUFFER bufId
  withArrayLen xs func -- give given vertices to OpenGL
  return bufId
  where
  func len ptr = glBufferData
    gl_ARRAY_BUFFER
    (fromIntegral (len * sizeOf (undefined :: GLfloat)))
    (ptr :: Ptr GLfloat)
    gl_STATIC_DRAW

bindBufferToAttrib :: GLuint -> GLuint -> IO ()
bindBufferToAttrib bufId attribLoc = do
  glEnableVertexAttribArray attribLoc
  glBindBuffer gl_ARRAY_BUFFER bufId
  glVertexAttribPointer
    attribLoc -- attribute location in the shader
    3 -- 3 components per vertex
    gl_FLOAT -- coord type
    (fromBool False) -- normalize?
    0 -- stride
    nullPtr -- vertex buffer offset

loadProgram :: String -> String -> IO GLuint
loadProgram vertShader fragShader = do
  shaderIds <- mapM (uncurry loadShader)
    [ (gl_VERTEX_SHADER, vertShader)
    , (gl_FRAGMENT_SHADER, fragShader)
    ]
  progId <- glCreateProgram
  putStrLn "Linking program"
  mapM_ (glAttachShader progId) shaderIds
  glLinkProgram progId
  _ <- checkStatus
    gl_LINK_STATUS glGetProgramiv glGetProgramInfoLog progId
  mapM_ glDeleteShader shaderIds
  return progId

loadShader :: GLenum -> String -> IO GLuint
loadShader shaderTypeFlag code = do
  shaderId <- glCreateShader shaderTypeFlag
  withCString code $ \codePtr ->
    with codePtr $ \codePtrPtr ->
      glShaderSource shaderId 1 codePtrPtr nullPtr
  putStrLn "Compiling shader..."
  glCompileShader shaderId
  _ <- checkStatus
    gl_COMPILE_STATUS glGetShaderiv glGetShaderInfoLog shaderId
  return shaderId

checkStatus :: (Integral a1, Storable a1)
  => GLenum
  -> (t -> GLenum -> Ptr a1 -> IO a)
  -> (t -> a1 -> Ptr a3 -> Ptr Foreign.C.Types.CChar -> IO a2)
  -> t
  -> IO Bool
checkStatus statusFlag glGetFn glInfoLogFn componentId = do
  let
    fetch info = withNewPtr (glGetFn componentId info)
  status <- liftM toBool $ fetch statusFlag
  logLength <- fetch gl_INFO_LOG_LENGTH
  when (logLength > 0) $
    allocaArray0 (fromIntegral logLength) $ \msgPtr -> do
      _ <- glInfoLogFn componentId logLength nullPtr msgPtr
      msg <- peekCString msgPtr
      (if status then putStrLn else fail) msg
  return status

fragmentShader1 :: String
fragmentShader1 = unlines
  [ "#version 330 core"
  , "out vec3 color;"
  , "void main()"
  , "{"
    , "color =  vec3(1,0,0);" -- paint it red!
  , "}"
  ]

vertexShader1 :: String
vertexShader1 = unlines
  [ "#version 330 core"
  , "layout(location = 0) in vec3 vPosition_modelspace;"
  , "void main()"
  , "{"
    , "gl_Position.xyz = vPosition_modelspace;"
    , "gl_Position.w = 1.0;"
  , "}"
  ]


vertexBufferData :: [GLfloat]
vertexBufferData =
  -- x, y, z
  [ -1, -1, 0
  ,  1, -1, 0
  ,  0,  1, 0
  ]

main :: IO ()
main = do
  win <- initialize
  glids <- initializeGL
  inputLoop win glids
  freeResources glids
  GLFW.terminate
  return ()

inputLoop :: GLFW.Window -> GLIDs -> IO ()
inputLoop win glids = do
  drawStuff glids
  GLFW.swapBuffers win
  GLFW.pollEvents
  keyState <- GLFW.getKey win GLFW.Key'Escape
  closeWindow <- GLFW.windowShouldClose win
  when (keyState /= GLFW.KeyState'Pressed && closeWindow == False) $
    inputLoop win glids

drawStuff :: GLIDs -> IO ()
drawStuff GLIDs{..} = do
  glClear gl_COLOR_BUFFER_BIT
  glClear gl_DEPTH_BUFFER_BIT
  glUseProgram progId
  bindBufferToAttrib vertexBufferId 0
  glDrawArrays gl_TRIANGLES 0 3 -- for attrib array 0, draw 3 vertices
  glDisableVertexAttribArray 0 -- disable attrib array 0

  1. Seriously, why do so many Haskell tutorials omit function type signatures?