Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/dodge

src/Shader.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Shader
     ( makeShader
-    , makeTextureShader
-    , makeShaderCustomUnis
+    , addTexture
+    , addUniforms
     , pokeShaders
     , pokeShader
     , bindArrayBuffers
@@ -28,6 +28,9 @@ import Codec.Picture
 import qualified Data.Vector.Storable as V
 
 import Control.Monad (when, forM, zipWithM_, forM_, foldM)
+import Control.Lens
+
+import Data.Maybe (fromMaybe)
 
 import qualified Control.Foldl as F
 
@@ -97,13 +100,10 @@ drawShader fs i = do
         _   -> return ()
     drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
 
-makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)] 
-            -> PrimitiveMode -> (a -> [[[Float]]]) 
-            -> String
-            -> IO (FullShader a)
-makeTextureShader s shaderlist alocs pm renStrat texturePath = do
-    (prog,unis)  <- makeSourcedShader s shaderlist
-
+-- I am not sure if this assumes that the shader is constructed directly before
+-- the texture is added...
+addTexture :: String -> FullShader a -> IO (FullShader a)
+addTexture texturePath shad = do
     Right cmap <- readImage texturePath
     let tex = convertRGBA8 cmap
     textureOb <- genObjectName
@@ -116,31 +116,7 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do
                         (PixelData RGBA UnsignedByte ptr)
     generateMipmap' Texture2D
     textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
-
-    vao        <- setupVAO alocs
-
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
-                        , _shaderCustomUnis = Nothing
-                        }
-
-makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) 
-                -> [String] -> IO (FullShader a)
-makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
-    (prog,unis,unis')  <- makeSourcedShaderCustomUnis s shaderlist uniStrings
-    vao        <- setupVAO alocs
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Nothing
-                        , _shaderCustomUnis = Just unis'
-                        }
+    return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
 
 makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
 makeShader s shaderlist alocs pm renStrat = do
@@ -203,12 +179,11 @@ makeSourcedShader s sts = do
                     $ \uniString -> uniformLocation prog uniString
     return (prog,uniformLocations)
 
-makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String] 
-                -> IO (Program, [UniformLocation], [UniformLocation])
-makeSourcedShaderCustomUnis s shadTypes uniStrings = do
-    (prog,unis0) <- makeSourcedShader s shadTypes
-    unis <- mapM (uniformLocation prog) uniStrings
-    return (prog,unis0,unis)
+addUniforms :: [String] -> FullShader a -> IO (FullShader a)
+addUniforms uniStrings shad = do
+    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
+    return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
+
 
 shaderTypeExt :: ShaderType -> String
 shaderTypeExt VertexShader   = ".vert"