summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Backend/GL/Backend.hs2
-rw-r--r--Backend/GL/Input.hs9
-rw-r--r--lambdacube-gl-ir.cabal2
3 files changed, 7 insertions, 6 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
diff --git a/lambdacube-gl-ir.cabal b/lambdacube-gl-ir.cabal
index 0d2600a..53144ce 100644
--- a/lambdacube-gl-ir.cabal
+++ b/lambdacube-gl-ir.cabal
@@ -62,7 +62,7 @@ library
62 GLFW-b >= 1.4.7, 62 GLFW-b >= 1.4.7,
63 vect >= 0.4.7, 63 vect >= 0.4.7,
64 pretty-show >=1.6 && <1.7, 64 pretty-show >=1.6 && <1.7,
65 lambdacube-compiler 65 lambdacube-ir
66 hs-source-dirs: . 66 hs-source-dirs: .
67 default-language: Haskell2010 67 default-language: Haskell2010
68 68