get something on screen. finally.

src/Classes/Graphics/VertexLayout.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Classes.Graphics.VertexLayout where
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+-- internal imports
+
+import Classes.Graphics.Bindable
+
+class (Bindable (VertBuffer v)) => VertexLayout v where
+
+  type VertBuffer v :: *
+
+  layoutElements :: v -> [(GL.GLuint, GL.VertexArrayDescriptor GL.GLfloat)]
+
+  addBuffer :: v -> VertBuffer v -> IO ()

src/Main.hs

@@ -5,14 +5,22 @@ import Affection
 
 import qualified Data.Text as T
 
+import SDL (($=), get)
 import qualified SDL
+import qualified SDL.Internal.Numbered as SDL
+import qualified SDL.Raw.Video as SDL (glSetAttribute)
+import qualified SDL.Raw.Enum as SDL
 
 import qualified Graphics.Rendering.OpenGL as GL
 
+import Control.Monad (when, void)
+
 import Control.Concurrent.STM
 
 import qualified Data.Map.Strict as M
 
+import Data.String (fromString)
+
 import Data.Maybe (isJust)
 
 import Linear
@@ -54,10 +62,7 @@ main = do
   withAffection config
 
 preLoad :: GameData -> Affection ()
-preLoad gd =
-  liftIO $ do
-    scene <- liftIO $ (initScene :: IO Test)
-    atomically $ putTMVar (gameScene gd) (Stage scene)
+preLoad _ = return ()
 
 handle :: GameData -> [SDL.EventPayload] -> Affection ()
 handle gd evs = do
@@ -66,37 +71,49 @@ handle gd evs = do
 
 update :: GameData -> Double -> Affection ()
 update gd dt = do
+  liftIO ((logIO Verbose) =<< (atomically $
+    (("Progress: " <>) . snd) <$> (readTMVar $ gameStateLoadProgress gd)))
   state <- liftIO $ atomically $ readTVar $ gameState gd
-  isStagePresent <- liftIO $ atomically $ isEmptyTMVar $ gameScene gd
+  isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd
   if isStagePresent
   then do
-    hasLoadThreadId <- isJust <$> (liftIO $ atomically $ readTVar $ gameLoadThread gd)
+    liftIO $ logIO Verbose "Stage is present"
     (Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd
     sceneLoaded <- isSceneLoaded sceneContainer
-    if not sceneLoaded && not hasLoadThreadId
-    then
+    if not sceneLoaded
+    then do
+      liftIO $ logIO Verbose "Loading scene"
       smLoad state gd
     else
       smUpdate state gd dt
   else
-    return ()
+    liftIO $ logIO Error "No Stage to play on"
 
 draw :: GameData -> Affection ()
 draw gd = do
   state <- liftIO (atomically $ readTVar $ gameState gd)
+  liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state)
+  GL.clearColor $= GL.Color4 0 0 1 1
   smDraw state gd
+  err <- SDL.get GL.errors
+  when (not $ null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err)))
 
 init :: IO GameData
-init = GameData
-  <$> newEmptyTMVarIO
-  <*> newTVarIO Loading
-  <*> newTMVarIO (0, "Ohai!")
-  <*> (Subsystems
-    <$> (SubWindow <$> newTVarIO [])
-    <*> (SubMouse <$> newTVarIO [])
-    <*> (SubKeyboard <$> newTVarIO [])
-    <*> (SubTranslator <$> newTVarIO [])
-    )
-  <*> newTVarIO (M.fromList [])
-  <*> newTVarIO True
-  <*> newTVarIO Nothing
+init = do
+  GL.blend $= GL.Enabled
+  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+  void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+  GameData
+    <$> (newTMVarIO =<< (Stage <$> (initScene :: IO Test)))
+    <*> newTVarIO Loading
+    <*> newTMVarIO (0, "Ohai!")
+    <*> (Subsystems
+      <$> (SubWindow <$> newTVarIO [])
+      <*> (SubMouse <$> newTVarIO [])
+      <*> (SubKeyboard <$> newTVarIO [])
+      <*> (SubTranslator <$> newTVarIO [])
+      )
+    <*> newTVarIO (M.fromList [])
+    <*> newTVarIO True
+    <*> newTVarIO Nothing
+    <*> newTVarIO Nothing

src/Renderer.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Renderer where
+
+import Affection
+
+import SDL (($=), get)
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import Data.String (fromString)
+
+import Control.Concurrent.STM
+
+import Foreign.Ptr
+
+-- internal imports
+
+import Classes.Graphics
+import Types.Graphics
+
+draw :: VertexArray -> IndexBuffer -> Shader -> IO ()
+draw va ib sp = do
+  bind sp
+  bind va
+  bind ib
+  count <- atomically $ readTVar $ iBufCount ib
+  GL.drawElements GL.Triangles count GL.UnsignedInt nullPtr
+
+-- clear :: IO ()
+-- clear = GL.clear [GL.ColorBuffer]

src/Scenes/Test.hs

@@ -8,6 +8,8 @@ import qualified SDL
 
 import qualified Graphics.Rendering.OpenGL as GL
 
+import qualified Data.Vector.Storable as VS
+
 import Control.Concurrent.STM
 
 import Control.Monad (void)
@@ -17,17 +19,30 @@ import Linear
 -- internal imports
 
 import Types
-import Map
 import Classes
+import Map
+import Renderer as R
 
 data Test = Test
   { testMap :: TMVar LevelMap
+  , testGraphics :: TMVar GLAssets
   , testLoaded :: TVar Bool
   }
 
+data GLAssets = GLAssets
+  { glVA :: VertexArray
+  , glVB :: VertexBuffer
+  , glIB :: IndexBuffer
+  , glSP :: Shader
+  }
+
 instance Scene Test where
 
-  initScene = Test <$> newEmptyTMVarIO <*> newTVarIO False
+  initScene =
+    Test
+      <$> newEmptyTMVarIO
+      <*> newEmptyTMVarIO
+      <*> newTVarIO False
 
   loadScene level progress = do
     atomically $ do
@@ -48,6 +63,42 @@ instance Scene Test where
 
     bind vertexArray
 
+    vertexBuffer <- newVertexBuffer 1024
+
+    bind vertexBuffer
+
+    let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0)
+
+    write vertexBuffer 0 vertices
+
+    indexBuffer <- newIndexBuffer 1024
+
+    bind indexBuffer
+
+    let indices = VS.fromList [0, 1, 2, 2, 3, 0]
+
+    write indexBuffer 0 indices
+
+    addBuffer (undefined :: Vertex) vertexBuffer
+
+    shader <- newShader
+      [ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
+      , ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
+      ]
+
+    bind shader
+    setUniform shader "u_mvp" (projection !*! view !*! model)
+
+    unbind vertexArray
+    unbind vertexBuffer
+    unbind indexBuffer
+    unbind shader
+
+    atomically $ do
+      putTMVar (testGraphics level)
+        (GLAssets vertexArray vertexBuffer indexBuffer shader)
+      writeTVar (testLoaded level) True
+
     void $ atomically $ do
       void $ takeTMVar progress
       putTMVar progress (1, "Loaded graphics!")
@@ -59,7 +110,10 @@ instance Scene Test where
 
   onEvents _ _ = return ()
 
-  render _ = return ()
+  render level = liftIO $ do
+    (GLAssets va vb ib sh) <- atomically (readTMVar $ testGraphics level)
+    bind vb
+    R.draw va ib sh
 
 testLevelDesc :: LevelDescriptor
 testLevelDesc = LevelDescriptor
@@ -69,3 +123,10 @@ testLevelDesc = LevelDescriptor
   "res/tiles/00_test/00_test.png"
   (3, 3)
 
+createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
+createQuad pos@(V2 x y) index =
+  [ newVertex (V3 x y 0)               (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
+  , newVertex (V3 (x + 32) y 0)        (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
+  , newVertex (V3 (x + 32) (y + 32) 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
+  , newVertex (V3 x (y + 32) 0)        (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
+  ]

src/State/Loading/Load.hs

@@ -16,15 +16,20 @@ import Foreign.Marshal.Array
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as B8
 
+import Control.Concurrent (forkIO)
+
 import Control.Concurrent.STM
 
 -- internal imports
 
 import Types
+import Classes
 import Map
 
 initLoad
   :: GameData
   -> Affection ()
-initLoad gd =
-  liftIO $ atomically $ writeTVar (gameState gd) Running
+initLoad gd = do
+  (Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
+  tid <- liftIO $ forkIO $ loadScene scene (gameStateLoadProgress gd)
+  liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)

src/StateMachine.hs

@@ -4,25 +4,55 @@ module StateMachine where
 
 import Affection
 
-import Control.Monad (void)
+import qualified SDL
+
+import Data.Maybe (isNothing, fromJust)
+
+import Control.Monad (void, when)
+
+import Control.Concurrent (forkIO)
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TVar
+import Control.Concurrent.STM.TMVar
 
 -- internal imports
 
 import Types
+import Classes
 
-import State.Loading
-import State.MainGame
+-- import State.Loading
+-- import State.MainGame
 
 instance StateMachine GameData State where
 
-  smLoad Loading = initLoad
-  smLoad x       = error ("State load not yet implemented: " <> show x)
+  smLoad Loading gd = do
+    mThreadId <- liftIO $ atomically $ readTVar (gameLoadThread gd)
+    when (isNothing mThreadId) $ do
+      (Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
+      -- ctx <- liftIO $ atomically $ fromJust <$>
+      --   (readTVar $ gameLoadContext gd)
+      ad <- get -- get inner state of engine
+      let win = ((\(_, y, _) -> y) $ head $ drawWindows ad)
+      liftIO $
+        loadScene scene (gameStateLoadProgress gd)
+      -- SDL.glMakeCurrent win (snd $ head $ glContext ad)
+      -- liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)
 
-  smUpdate Loading = initLoadUpdate
-  smUpdate x       = error ("State update not yet implemented: " <> show x)
+  smLoad x       _ = error ("State load not yet implemented: " <> show x)
+
+
+  smUpdate Loading _ _ = return ()
+
+  smUpdate x       _ _ = error ("State update not yet implemented: " <> show x)
+
+
+  smDraw Loading gd = do
+    (Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
+    render scene
+
+  smDraw x       _ = error ("State draw not yet implemented: " <> show x)
 
-  smDraw Loading = initLoadDraw
-  smDraw x       = error ("State draw not yet implemented: " <> show x)
 
   smEvent _ gd evs = do
     let Subsystems w m k _ = gameSubsystems gd
@@ -30,4 +60,5 @@ instance StateMachine GameData State where
       consumeSDLEvents m =<<
       consumeSDLEvents w evs
 
-  smClean x = error ("State clean not yet implemented: " <> show x)
+
+  smClean x _ = error ("State clean not yet implemented: " <> show x)

src/Types/Application.hs

@@ -28,6 +28,7 @@ data GameData = GameData
   , gameActionTranslation :: TVar ActionTranslation
   , gameRunning           :: TVar Bool
   , gameLoadThread        :: TVar (Maybe ThreadId)
+  , gameLoadContext       :: TVar (Maybe SDL.GLContext)
   }
 
 -- Existential type wrapper to make all Scenes implementing Scene

src/Types/Graphics.hs

@@ -4,3 +4,5 @@ module Types.Graphics
 
 import Types.Graphics.VertexArray as G
 import Types.Graphics.VertexBuffer as G
+import Types.Graphics.IndexBuffer as G
+import Types.Graphics.Shader as G

src/Types/Graphics/IndexBuffer.hs

@@ -1,17 +1,25 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Types.Graphics.IndexBuffer where
 
+import Affection
+
 import qualified Graphics.Rendering.OpenGL as GL
 
-import SDL (($=), get)
+import SDL (($=))
+
+import Data.String (fromString)
 
 import qualified Data.Vector.Storable as VS
 
+import Control.Monad (when)
 import Control.Monad.Loops (whileM_)
 
-import Control.Concurent.STM
+import Control.Concurrent.STM
 
 import Foreign
+import Foreign.C.Types
 
 -- internal imports
 
@@ -23,7 +31,7 @@ data IndexBuffer = IndexBuffer
   { iBufId    :: TVar GL.BufferObject -- buffer id
   , iBufSize  :: TVar GL.GLsizeiptr   -- size of data
   -- , iBufData  :: Ptr a           -- pointer to data
-  -- , iBufCount :: GL.GLint        -- number of data elements
+  , iBufCount :: TVar GL.GLint        -- number of data elements
   }
 
 -- instanciate typeclass from Buffer and fill in missing implementations
@@ -40,9 +48,10 @@ instance Buffer IndexBuffer where
   initialize buf = do
     -- bind the buffer using the default iplementation of the typeclass
     bind buf
+    size <- readTVarIO $ iBufSize buf
     -- fill in the data
     GL.bufferData (target buf) $=
-      ( iBufSize buf
+      ( size
       , nullPtr
       , GL.DynamicDraw
       )
@@ -52,12 +61,13 @@ instance Buffer IndexBuffer where
   write buf offset dat = do
     currentBufSize <- readTVarIO (iBufSize buf)
     whileM_
-      (pure $ (offset + VS.length dat) *
+      (pure $ (fromIntegral offset + VS.length dat) *
         sizeOf (undefined :: StoreType IndexBuffer)
-        > currentBufSize) $ do
+        > fromIntegral currentBufSize) $ do
           allocaArray
-            (currentBufSize `div` sizeOf (undefined :: StoreType IndexBuffer))
-            $ \ ptr -> do
+            (fromIntegral currentBufSize `div`
+              sizeOf (undefined :: StoreType IndexBuffer))
+            $ \ (ptr :: Ptr (StoreType IndexBuffer)) -> do
               GL.bufferSubData
                 (target buf)
                 GL.ReadFromBuffer
@@ -74,12 +84,17 @@ instance Buffer IndexBuffer where
                 ptr
     -- bind buffer, just to be safe
     bind buf
-    VS unsafeWith dat $ \ ptr ->
+    let elemCount = fromIntegral offset + VS.length dat
+    logIO Verbose ("elemCount: " <> (fromString $ show elemCount))
+    currentCount <- atomically $ readTVar (iBufCount buf)
+    when (fromIntegral elemCount > currentCount) $
+      atomically $ writeTVar (iBufCount buf) (fromIntegral elemCount)
+    VS.unsafeWith dat $ \ ptr ->
       GL.bufferSubData
         (target buf)
         GL.WriteToBuffer
         (CPtrdiff $ fromIntegral offset *
-          sizeOf (undefined :: StoreType IndexBuffer))
+          fromIntegral (sizeOf (undefined :: StoreType IndexBuffer)))
         (CPtrdiff $ fromIntegral $
           VS.length dat * sizeOf (undefined :: StoreType IndexBuffer))
         ptr
@@ -90,19 +105,20 @@ instance Buffer IndexBuffer where
     newId <- GL.genObjectName
     newSize <- (2 *) <$> readTVarIO (iBufSize buf)
     atomically $ do
-      writeTvar (iBufId buf) newId
-      writeTvar (iBUfSize buf) newSize
+      writeTVar (iBufId buf) newId
+      writeTVar (iBufSize buf) newSize
     initialize buf
 
   delete buf = do
     unbind buf
-    GL.deleteObjectname ==< (readTVarIO $ vBufId buf)
+    GL.deleteObjectName =<< (readTVarIO $ iBufId buf)
 
 
-instance Bindable (IndexBuffer a) where
+instance Bindable IndexBuffer where
 
   -- bind the buffer
-  bind buf = GL.bindBuffer (target buf) $= Just (glId buf)
+  bind buf =
+    (\ a -> GL.bindBuffer (target buf) $= Just a) =<< glId buf
 
   -- unbind the buffer
   unbind buf = GL.bindBuffer (target buf) $= Nothing
@@ -114,13 +130,14 @@ newIndexBuffer initLength = do
   -- create the buffer object in applicative style
   buf <- IndexBuffer
     -- generate the ID
-    <$> GL.genObjectName
+    <$> (newTVarIO =<< GL.genObjectName)
     -- compute buffer size
-    <*> pure (fromIntegral initLength)
+    <*> newTVarIO (CPtrdiff (fromIntegral $
+      (fromIntegral initLength * sizeOf (undefined :: StoreType IndexBuffer))))
     -- -- make pointer out of list
     -- <*> newArray list
     -- -- get count
-    -- <*> pure (fromIntegral $ length list)
+    <*> newTVarIO 0
   -- fill the data in to the buffer
   initialize buf
   -- return the data object

src/Types/Graphics/Shader.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Types.Graphics.Shader where
+
+import SDL (($=), get)
+
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GL as GLRaw
+
+import Data.List as L
+
+import Data.StateVar
+
+import qualified Data.ByteString as B
+
+import Data.Maybe (fromJust)
+
+import Control.Concurrent.MVar
+
+import Linear
+
+import Foreign.Marshal.Utils (with)
+import Foreign.Marshal.Array (withArray)
+import Foreign.Storable
+import Foreign.Ptr
+
+-- internal imports
+
+import Classes.Graphics.Bindable
+
+data Shader = Shader
+  { shaderId :: GL.Program
+  , shaderSources  :: [ShaderSource]
+  , shaderUniforms :: MVar [ShaderUniform]
+  }
+
+-- make Shader Bindable
+instance Bindable Shader where
+
+  bind s = GL.currentProgram $= Just (shaderId s)
+
+  unbind _ = GL.currentProgram $= Nothing
+
+data ShaderSource = ShaderSource
+  { shaderSourceType :: GL.ShaderType
+  , shaderPath       :: FilePath
+  }
+
+data ShaderUniform = ShaderUniform
+  { shaderUniformName     :: String
+  , shaderUniformLocation :: GL.UniformLocation
+  }
+
+-- orphan instance to make linear's M44 uniforms
+instance GL.Uniform (M44 GL.GLfloat) where
+  uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
+    where
+      getter = error "cannot implement: get uniform M44 GLfloat"
+        -- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
+      setter (V4
+        (V4 a b c d)
+        (V4 e f g h)
+        (V4 i j k l)
+        (V4 m n o p)) = do
+          mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
+          GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
+  uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
+    -- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
+    -- where
+    --   elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
+
+-- getUniformWith :: (GL.GLuint -> GL.GLint -> Ptr a -> IO ()) -> GL.UniformLocation -> Ptr a -> IO ()
+-- getUniformWith getter (GL.UniformLocation ul) buf = do
+--   program <- fmap (GL.programID . fromJust) $ get GL.currentProgram
+--   getter program ul buf
+
+isRowMajor :: GL.MatrixOrder -> GL.GLboolean
+isRowMajor p = if (GL.RowMajor == p) then 1 else 0
+
+-- create new data object of type Shader
+newShader :: [ShaderSource] -> IO Shader
+newShader shaderSrc = do
+  -- create program Object
+  program <- GL.createProgram
+
+  -- create shaders from the source codes given
+  compilates <- mapM
+    (\(ShaderSource type_ path) -> do
+      -- read in shader source from File
+      source<- B.readFile path
+      
+      -- compile the shader
+      compiledShader <- compileShaderSource type_ source
+      return (type_, compiledShader)
+      )
+    shaderSrc
+
+  -- attach, link and validate the shader program
+  GL.attachedShaders program $= map snd compilates
+  GL.linkProgram program
+  GL.validateProgram program 
+
+  ok <- get (GL.validateStatus program)
+  if ok
+  then
+    putStrLn "Shaderprogram linked successfully!"
+  else do
+    info <- get (GL.programInfoLog program)
+    putStrLn "Shaderprogram linking failed!\nInfo log says:"
+    putStrLn info
+    GL.deleteObjectName program
+
+  -- throw away the shaders, since they are linked into the shader program
+  mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)
+
+  -- return data object
+  Shader program shaderSrc <$> newMVar []
+
+-- pass uniform values into Shader program
+setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
+setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
+  -- check if uniform location is already cached
+  locs <- readMVar shaderUniforms
+
+  -- retrieve uniform location
+  let unilocs = filter
+        (\(ShaderUniform name _) -> name == uniname)
+        locs
+
+  case unilocs of
+    [] -> do
+      print ("Unknown uniform: " <> uniname)
+      print "Retrieving uniform location from shader program"
+      loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
+      if locNum < 0
+      then
+        print ("Uniform does not exist in shader program: " <> uniname)
+      else do
+        -- set the data
+        withArray data_ $ \ptr ->
+          GL.uniformv loc (fromIntegral $ length data_) ptr
+        --GL.uniform loc $= data_
+        -- add uniform to cache
+        modifyMVar_ shaderUniforms
+          (\list -> return $ ShaderUniform uniname loc : list)
+    [ShaderUniform _ loc] ->
+        -- set the data
+        withArray data_ $ \ptr ->
+          GL.uniformv loc (fromIntegral $ length data_) ptr
+
+setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
+setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
+  -- check if uniform location is already cached
+  locs <- readMVar shaderUniforms
+
+  -- retrieve uniform location
+  let unilocs = filter
+        (\(ShaderUniform name _) -> name == uniname)
+        locs
+
+  case unilocs of
+    [] -> do
+      print ("Unknown uniform: " <> uniname)
+      print "Retrieving uniform location from shader program"
+      loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
+      if locNum < 0
+      then
+        print ("Uniform does not exist in shader program: " <> uniname)
+      else do
+        -- set the data
+        --withArray data_ $ \ptr ->
+        --  GL.uniformv loc (length data_) ptr
+        GL.uniform loc $= data_
+        -- add uniform to cache
+        modifyMVar_ shaderUniforms
+          (\list -> return $ ShaderUniform uniname loc : list)
+    [ShaderUniform _ loc] ->
+        -- set the data
+        GL.uniform loc $= data_
+
+-- | compile a shader from source
+compileShaderSource
+  :: GL.ShaderType -- ^ what type of shader we are compiling
+  -> B.ByteString    -- ^ its source code
+  -> IO GL.Shader
+compileShaderSource type_ source = do
+  -- create shader object of specified type
+  shaderObject <- GL.createShader type_
+
+  -- assign source code to shader object
+  GL.shaderSourceBS shaderObject $= source
+
+  -- actually compile the shader
+  GL.compileShader shaderObject
+
+  -- error handling
+  ok <- GL.compileStatus shaderObject
+
+  if ok
+  then
+    putStrLn (show type_ ++ ": compilation successful!")
+  else do
+    info <- get (GL.shaderInfoLog shaderObject)
+    putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
+    putStrLn info
+    GL.deleteObjectName shaderObject
+
+  return shaderObject

src/Types/Graphics/VertexArray.hs

@@ -18,7 +18,6 @@ import Control.Monad (void)
 
 import Classes.Graphics.Bindable
 import Classes.Graphics.Buffer
-import Classes.Graphics.VertexLayout
 import Types.Graphics.VertexBuffer
 
 newtype VertexArray = VertexArray
@@ -35,40 +34,3 @@ instance Bindable VertexArray where
 newVertexArray :: IO VertexArray
 newVertexArray = VertexArray
   <$> GL.genObjectName
-
-instance VertexLayout Vertex where
-
-  type VertArray Vertex = VertexArray
-
-  layoutElements vert =
-    foldr
-      (\a@(index, count) acc -> 
-        ( index
-        , GL.VertexArrayDescriptor
-          count
-          GL.Float
-          (fromIntegral $ sizeOf (undefined :: Vertex))
-          (nullPtr `plusPtr` (sizeOf (undefined :: GL.GLfloat) * fromIntegral
-            (sum (map ((\(GL.VertexArrayDescriptor c _ _ _) -> c) . snd) acc))))
-        ) : acc
-        )
-      []
-      (zip [0 ..] [3, 4, 2, 1])
-
-  addBuffer vert va vb = do
-    -- bind vertex array and vertex buffer ot associate them
-    bind va
-    bind vb
-    -- enable and fill vertex attrib pointer(s)
-    let list = layoutElements vert
-    mapM_
-      (\(index, descriptor) -> do
-        GL.vertexAttribArray (GL.AttribLocation index) $= GL.Enabled
-        GL.vertexAttribPointer (GL.AttribLocation index) $=
-          ( GL.ToNormalizedFloat
-          , descriptor
-          )
-        )
-      list
-    unbind va
-    unbind vb

src/Types/Graphics/VertexBuffer.hs

@@ -27,6 +27,7 @@ import GHC.Generics
 
 import Classes.Graphics.Bindable
 import Classes.Graphics.Buffer
+import Classes.Graphics.VertexLayout
 
 -- | layout of the VertexBuffer data object
 data VertexBuffer = VertexBuffer
@@ -174,10 +175,45 @@ newVertexBuffer initSize = do
     <$> (newTVarIO =<< GL.genObjectName)
     -- compute buffer size
     <*> (newTVarIO (CPtrdiff (fromIntegral $
-      fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer))))
+      (fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer)))))
     -- make pointer out of list
     -- <*> newArray list
   -- fill the data in to the buffer
   initialize buf
   -- return the data object
   return buf
+
+instance VertexLayout Vertex where
+
+  type VertBuffer Vertex = VertexBuffer
+
+  layoutElements _ =
+    foldl
+      (\acc a@(index, count) -> 
+        ( index
+        , GL.VertexArrayDescriptor
+          count
+          GL.Float
+          (fromIntegral $ sizeOf (undefined :: Vertex))
+          (nullPtr `plusPtr` (sizeOf (undefined :: GL.GLfloat) * fromIntegral
+            (sum (map ((\(GL.VertexArrayDescriptor c _ _ _) -> c) . snd) acc))))
+        ) : acc
+        )
+      []
+      (zip [0 ..] [3, 4, 2, 1])
+
+  addBuffer vert vb = do
+    -- bind vertex buffer to associate them
+    bind vb
+    -- enable and fill vertex attrib pointer(s)
+    let list = layoutElements vert
+    mapM_
+      (\(index, descriptor) -> do
+        GL.vertexAttribArray (GL.AttribLocation index) $= GL.Enabled
+        GL.vertexAttribPointer (GL.AttribLocation index) $=
+          ( GL.ToNormalizedFloat
+          , descriptor
+          )
+        )
+      list
+    unbind vb