diff options
Diffstat (limited to 'src/LambdaCube/GL/Input.hs')
-rw-r--r-- | src/LambdaCube/GL/Input.hs | 16 |
1 files changed, 7 insertions, 9 deletions
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs index bd46fe0..d63fe69 100644 --- a/src/LambdaCube/GL/Input.hs +++ b/src/LambdaCube/GL/Input.hs | |||
@@ -226,7 +226,7 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ | |||
226 | , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap | 226 | , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap |
227 | ] | 227 | ] |
228 | uniInputType (GLTypedUniform ty _) = unwitnessType ty | 228 | uniInputType (GLTypedUniform ty _) = unwitnessType ty |
229 | uniInputType (GLUniform ty _) = ty | 229 | uniInputType (GLUniform r) = objectType r |
230 | 230 | ||
231 | -- object attribute stream commands | 231 | -- object attribute stream commands |
232 | objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] | 232 | objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] |
@@ -288,16 +288,14 @@ name @= val = do | |||
288 | Nothing -> do | 288 | Nothing -> do |
289 | tell [throwIO $ typeMismatch ty ref] | 289 | tell [throwIO $ typeMismatch ty ref] |
290 | 290 | ||
291 | GLUniform FTexture2D ref -> case withTypes val ref <$> eqT of | 291 | GLUniform ref -> case withTypes val ref <$> eqT of |
292 | Just Refl -> tell [val >>= writeIORef ref] | 292 | Just Refl -> tell [val >>= writeIORef ref] |
293 | Nothing -> tell [ Prelude.putStrLn $ "WARNING: Texture2D variable " | 293 | Nothing -> tell [ Prelude.putStrLn $ "WARNING: "++show (objectType ref)++" variable " |
294 | ++ show name | 294 | ++ show name |
295 | ++ " cannot recieve value " ++ show (typeRep val) | 295 | ++ " cannot recieve value " ++ show (typeRep val) |
296 | , throwIO $ typeMismatch ref val | 296 | , throwIO $ typeMismatch ref val |
297 | ] | 297 | ] |
298 | 298 | ||
299 | GLUniform ty _ -> tell [Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show name ++ " :: " ++ show ty] | ||
300 | |||
301 | 299 | ||
302 | updateUniforms :: GLStorage -> UniM a -> IO () | 300 | updateUniforms :: GLStorage -> UniM a -> IO () |
303 | updateUniforms storage (UniM m) = sequence_ l where | 301 | updateUniforms storage (UniM m) = sequence_ l where |
@@ -325,11 +323,11 @@ setGLUniform resolv name u val = case u of | |||
325 | , "to", show (typeOf val) | 323 | , "to", show (typeOf val) |
326 | , "value." ] | 324 | , "value." ] |
327 | 325 | ||
328 | GLUniform textureType ref -> case withTypes (Just val) ref <$> eqT of | 326 | GLUniform ref -> case withTypes (Just val) ref <$> eqT of |
329 | Just Refl -> writeIORef ref val | 327 | Just Refl -> writeIORef ref val |
330 | Nothing -> warn $ unwords [ show textureType | 328 | Nothing -> warn $ unwords [ "uniform", name |
331 | , "uniform", name | 329 | , "only accepts values of type" |
332 | , "only accepts values of type TextureData." ] | 330 | , show $ typeRep ref ] |
333 | where warn s = putStrLn $ "WARNING: " ++ s | 331 | where warn s = putStrLn $ "WARNING: " ++ s |
334 | 332 | ||
335 | -- | Lookup and set a Uniform ref. | 333 | -- | Lookup and set a Uniform ref. |