summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Backend.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Backend.hs')
-rw-r--r--src/LambdaCube/GL/Backend.hs39
1 files changed, 20 insertions, 19 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index bb45fbd..a5507f3 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -199,12 +199,12 @@ printFBOStatus = checkFBO >>= print
199compileProgram :: Map String InputType -> Program -> IO GLProgram 199compileProgram :: Map String InputType -> Program -> IO GLProgram
200compileProgram uniTrie p = do 200compileProgram uniTrie p = do
201 po <- glCreateProgram 201 po <- glCreateProgram
202 putStrLn $ "compile program: " ++ show po 202 --putStrLn $ "compile program: " ++ show po
203 let createAndAttach src t = do 203 let createAndAttach src t = do
204 o <- glCreateShader t 204 o <- glCreateShader t
205 compileShader o [src] 205 compileShader o [src]
206 glAttachShader po o 206 glAttachShader po o
207 putStr " + compile shader source: " >> printGLStatus 207 --putStr " + compile shader source: " >> printGLStatus
208 return o 208 return o
209 209
210 objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of 210 objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of
@@ -212,9 +212,9 @@ compileProgram uniTrie p = do
212 Just s -> [createAndAttach s GL_GEOMETRY_SHADER] 212 Just s -> [createAndAttach s GL_GEOMETRY_SHADER]
213 213
214 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do 214 forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do
215 putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) 215 --putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
216 glBindFragDataLocation po i $ castPtr pn 216 glBindFragDataLocation po i $ castPtr pn
217 putStr " + setup shader output mapping: " >> printGLStatus 217 --putStr " + setup shader output mapping: " >> printGLStatus
218 218
219 glLinkProgram po 219 glLinkProgram po
220 printProgramLog po 220 printProgramLog po
@@ -226,18 +226,19 @@ compileProgram uniTrie p = do
226 -- check program input 226 -- check program input
227 (uniforms,uniformsType) <- queryUniforms po 227 (uniforms,uniformsType) <- queryUniforms po
228 (attributes,attributesType) <- queryStreams po 228 (attributes,attributesType) <- queryStreams po
229 print uniforms 229 --print uniforms
230 print attributes 230 --print attributes
231 let lcUniforms = (programUniforms p) `Map.union` (programInTextures p) 231 let lcUniforms = (programUniforms p) `Map.union` (programInTextures p)
232 lcStreams = fmap ty (programStreams p) 232 lcStreams = fmap ty (programStreams p)
233 check a m = and $ map go $ Map.toList m 233 check a m = and $ map go $ Map.toList m
234 where go (k,b) = case Map.lookup k a of 234 where go (k,b) = case Map.lookup k a of
235 Nothing -> False 235 Nothing -> False
236 Just x -> x == b 236 Just x -> x == b
237 unless (check lcUniforms uniformsType) $ do 237 unless (check lcUniforms uniformsType) $ fail $ unlines
238 putStrLn $ "expected: " ++ show lcUniforms 238 [ "shader program uniform input mismatch!"
239 putStrLn $ "actual: " ++ show uniformsType 239 , "expected: " ++ show lcUniforms
240 fail "shader program uniform input mismatch!" 240 , "actual: " ++ show uniformsType
241 ]
241 unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) 242 unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
242 -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input 243 -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input
243 let inUniNames = programUniforms p 244 let inUniNames = programUniforms p
@@ -245,17 +246,17 @@ compileProgram uniTrie p = do
245 inTextureNames = programInTextures p 246 inTextureNames = programInTextures p
246 inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms 247 inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms
247 texUnis = [n | (n,_) <- inTextures, Map.member n uniTrie] 248 texUnis = [n | (n,_) <- inTextures, Map.member n uniTrie]
248 putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie) 249 --putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie)
249 putStrLn $ "inUniNames: " ++ show inUniNames 250 --putStrLn $ "inUniNames: " ++ show inUniNames
250 putStrLn $ "inUniforms: " ++ show inUniforms 251 --putStrLn $ "inUniforms: " ++ show inUniforms
251 putStrLn $ "inTextureNames: " ++ show inTextureNames 252 --putStrLn $ "inTextureNames: " ++ show inTextureNames
252 putStrLn $ "inTextures: " ++ show inTextures 253 --putStrLn $ "inTextures: " ++ show inTextures
253 putStrLn $ "texUnis: " ++ show texUnis 254 --putStrLn $ "texUnis: " ++ show texUnis
254 let valA = Map.toList $ attributes 255 let valA = Map.toList $ attributes
255 valB = Map.toList $ programStreams p 256 valB = Map.toList $ programStreams p
256 putStrLn "------------" 257 --putStrLn "------------"
257 print $ Map.toList $ attributes 258 --print $ Map.toList $ attributes
258 print $ Map.toList $ programStreams p 259 --print $ Map.toList $ programStreams p
259 let lcStreamName = fmap name (programStreams p) 260 let lcStreamName = fmap name (programStreams p)
260 return $ GLProgram 261 return $ GLProgram
261 { shaderObjects = objs 262 { shaderObjects = objs