This is the code that

OpenGL Haskell Performance Problem

vertex   = "#version 110\n attribute vec3 position; void main() { gl_Position = vec4(position, 1.0); }"
fragment = "#version 110\n void main() { gl_FragColor = vec4(1.0, 0.0, 0.0, 1.0); } "
time     = Monotonic

tris = [Triangle 0 0 0 (cos x) (sin x) 0 (cos (x^2)) (sin (x^2)) 0 | x <- [0.0,0.08..2*pi]]
nums = zip tris [0..]
len  = length tris

main = do
  withBasicWindow windowWidth windowHeight "Metropolis" $ \window -> do
    buffer         <- createVertexBuffer
    triangleShader <- compileShaderProgram "triangles" vertex fragment
    channel        <- newTChanIO
    vector         <- M.new $ len
    setupEventHandlers window channel

    let buffers   = Buffers vector
        gameState = GameState buffer (pi / 2) 0.02 (windowHeight/windowWidth)
        shaders   = Shaders triangleShader

    gameLoop window channel buffers shaders gameState 30

createVertexBuffer = do
  alloca $ \bufferPtr -> do
    glGenBuffers 1 bufferPtr
    bufferId <- peek bufferPtr
        return bufferId

gameLoop window channel buffers shaders gameState previousFps = do
  startTime    <- getTime time
  newGameState <- gameFrame window channel buffers shaders gameState
  endGame      <- windowShouldClose window
  endTime      <- getTime time
  print $ truncate $ fps startTime endTime
  if endGame then return () else gameLoop window channel buffers shaders newGameState (previousFps * 0.1 + newFps * 0.9)

fps (TimeSpec a b) (TimeSpec x y) = 1 / frameTime
  where frameTime  = seconds + nanosecond
        seconds    = fromIntegral $ x - a
        nanosecond = fromIntegral (y - b) / (10^9)

gameFrame window channel buffers shaders gameState' = do
  pollEvents
  gameState <- processEvents channel gameState'
  clearWindow

  mapM_ (\(t, i) -> M.write (triangles buffers) i t) nums

  let (ptr, size) = M.unsafeToForeignPtr0 (triangles buffers)
  activateShaderProgram (triangleShader shaders)
  bufferData (buffer gameState') ptr (size * sizeOf (undefined :: Triangle))
  describeBufferedData (triangleShader shaders) [("position", 3, gl_FLOAT, 0, 0)]
  drawArrays (3 * len) -- This is line is incredibly slow (3 frames per second)
                       -- Without it, this runs at thousands of frames per second

  swapBuffers window
  return gameState
  
describeBufferedData (Shader programId) attributes = mapM_ describeAttribute attributes
  where describeAttribute (name, size, openGLType, stride, offset) = do
          withCString name $ \namePtr -> do
            location <- glGetAttribLocation programId namePtr
            glEnableVertexAttribArray $ fromIntegral location
            glVertexAttribPointer (fromIntegral location) (fromIntegral size) openGLType (fromIntegral gl_FALSE) (fromIntegral stride) (plusPtr nullPtr offset)
            
bufferData buffer dataPtr size = do
  withForeignPtr dataPtr $ \ptr -> do
    glBindBuffer gl_ARRAY_BUFFER buffer
    glBufferData gl_ARRAY_BUFFER (fromIntegral size) ptr gl_STREAM_DRAW

drawArrays vertexCount = glDrawArrays gl_TRIANGLES 0 (fromIntegral vertexCount)

processEvents channel gameState = do
  event <- nextEvent channel
  return $ case event of
    Nothing    -> gameState
    Just event -> applyEvent event gameState
    
nextEvent channel = atomically $ do
  channelIsEmpty <- isEmptyTChan channel
  if channelIsEmpty
    then return Nothing
    else do
      event <- readTChan channel
      return $ Just event