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?