2014-03-15*
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.
 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