summaryrefslogtreecommitdiff
path: root/Backend/GL
diff options
context:
space:
mode:
Diffstat (limited to 'Backend/GL')
-rw-r--r--Backend/GL/Backend.hs2
-rw-r--r--Backend/GL/Input.hs9
2 files changed, 6 insertions, 5 deletions
diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs
index 4780966..d3abfad 100644
--- a/Backend/GL/Backend.hs
+++ b/Backend/GL/Backend.hs
@@ -233,7 +233,7 @@ compileProgram uniTrie p = do
233 lcStreams = fmap ty (toTrie $ programStreams p) 233 lcStreams = fmap ty (toTrie $ programStreams p)
234 check a m = and $ map go $ T.toList m 234 check a m = and $ map go $ T.toList m
235 where go (k,b) = case T.lookup k a of 235 where go (k,b) = case T.lookup k a of
236 Nothing -> True 236 Nothing -> False
237 Just x -> x == b 237 Just x -> x == b
238 unless (check lcUniforms uniformsType) $ do 238 unless (check lcUniforms uniformsType) $ do
239 putStrLn $ "expected: " ++ show lcUniforms 239 putStrLn $ "expected: " ++ show lcUniforms
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
index 2b7c3d3..e1d06b7 100644
--- a/Backend/GL/Input.hs
+++ b/Backend/GL/Input.hs
@@ -85,7 +85,7 @@ addObject input slotName prim indices attribs uniformNames = do
85 ] 85 ]
86 86
87 let slotIdx = case slotName `T.lookup` slotMap input of 87 let slotIdx = case slotName `T.lookup` slotMap input of
88 Nothing -> error "internal error (slot index)" 88 Nothing -> error $ "internal error (slot index): " ++ show slotName
89 Just i -> i 89 Just i -> i
90 seed = objSeed input 90 seed = objSeed input
91 order <- newIORef 0 91 order <- newIORef 0
@@ -194,13 +194,13 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
194 where 194 where
195 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis] 195 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis]
196 uniMap = T.toList $ inputUniforms prg 196 uniMap = T.toList $ inputUniforms prg
197 topUni n = T.lookupWithDefault (error "internal error (createObjectCommands)!") n topUnis 197 topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis
198 objUnis = objUniSetup obj 198 objUnis = objUniSetup obj
199 texUnis = S.toList $ inputTextureUniforms prg 199 texUnis = S.toList $ inputTextureUniforms prg
200 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u 200 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
201 | n <- texUnis 201 | n <- texUnis
202 , let u = T.lookupWithDefault (topUni n) n objUnis 202 , let u = T.lookupWithDefault (topUni n) n objUnis
203 , let texUnit = T.lookupWithDefault (error "internal error (createObjectCommands - Texture Unit)") n texUnitMap 203 , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
204 ] 204 ]
205 uniInputType (GLUniform ty _) = ty 205 uniInputType (GLUniform ty _) = ty
206 206
@@ -243,7 +243,8 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
243 constAttr -> GLSetVertexAttrib i constAttr 243 constAttr -> GLSetVertexAttrib i constAttr
244 244
245nullSetter :: ByteString -> String -> a -> IO () 245nullSetter :: ByteString -> String -> a -> IO ()
246nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t 246--nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
247nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
247 248
248uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool 249uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool
249uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B 250uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B