summaryrefslogtreecommitdiff
path: root/src/LambdaCube
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube')
-rw-r--r--src/LambdaCube/GL.hs3
-rw-r--r--src/LambdaCube/GL/Input.hs12
2 files changed, 11 insertions, 4 deletions
diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 2b5c814..f852eab 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -90,7 +90,8 @@ module LambdaCube.GL (
90 makeSchema, 90 makeSchema,
91 91
92 (@=), 92 (@=),
93 updateUniforms 93 updateUniforms,
94 updateObjectUniforms
94) where 95) where
95 96
96import LambdaCube.GL.Type 97import LambdaCube.GL.Type
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 7a3b809..00b2773 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -394,12 +394,12 @@ uniformFTexture2D n is = case Map.lookup n is of
394 Just (SFTexture2D fun) -> fun 394 Just (SFTexture2D fun) -> fun
395 _ -> nullSetter n "FTexture2D" 395 _ -> nullSetter n "FTexture2D"
396 396
397type UniM = Writer [GLStorage -> IO ()] 397type UniM = Writer [Map GLUniformName InputSetter -> IO ()]
398 398
399class UniformSetter a where 399class UniformSetter a where
400 (@=) :: GLUniformName -> IO a -> UniM () 400 (@=) :: GLUniformName -> IO a -> UniM ()
401 401
402setUniM setUni n act = tell [\s -> let f = setUni n (uniformSetter s) in f =<< act] 402setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act]
403 403
404instance UniformSetter Bool where (@=) = setUniM uniformBool 404instance UniformSetter Bool where (@=) = setUniM uniformBool
405instance UniformSetter V2B where (@=) = setUniM uniformV2B 405instance UniformSetter V2B where (@=) = setUniM uniformV2B
@@ -428,4 +428,10 @@ instance UniformSetter M43F where (@=) = setUniM uniformM43F
428instance UniformSetter M44F where (@=) = setUniM uniformM44F 428instance UniformSetter M44F where (@=) = setUniM uniformM44F
429instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D 429instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
430 430
431updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l 431updateUniforms storage m = sequence_ l where
432 setters = uniformSetter storage
433 l = map ($ setters) $ execWriter m
434
435updateObjectUniforms object m = sequence_ l where
436 setters = objectUniformSetter object
437 l = map ($ setters) $ execWriter m