Representation-agnostic matrix/vector pipeline inputs.

1 files changed, 18 insertions, 72 deletions

diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index bd3f827..97b8e25 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -5,6 +5,7 @@ import Data.IORef
 import Data.Int
 import Data.IntMap.Strict (IntMap)
 import Data.Set (Set)
+import Data.Typeable
 import Data.Map (Map)
 import Data.Vector (Vector)
 import Data.Word
@@ -14,11 +15,12 @@ import Data.ByteString
 
 import Graphics.GL.Core33
 
-import LambdaCube.Linear
+import LambdaCube.GL.Input.Type
 import LambdaCube.IR
+import LambdaCube.Linear
 import LambdaCube.PipelineSchema
 
-type GLUniformName = ByteString
+type GLUniformName = String
 
 ---------------
 -- Input API --
@@ -67,10 +69,21 @@ data ArrayDesc
     - independent from pipeline
     - per object features: enable/disable visibility, set render ordering
 -}
-data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)
+data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUniformValue c))
+               | GLUniform !InputType !(IORef TextureData)
+
+data GLUniformValue c = forall a. GLData a c => GLUniformValue a
 
 instance Show GLUniform where
-    show (GLUniform t _) = "GLUniform " ++ show t
+    showsPrec d (GLTypedUniform t _) = paren '('
+                                     . mappend "GLUniform "
+                                     . showsPrec (d+10) (unwitnessType t)
+                                     . paren ')'
+        where paren | d<=10     = (:)
+                    | otherwise = \_ -> id
+    showsPrec d (GLUniform t _) = paren '(' . mappend "GLUniform " . showsPrec (d+10) t . paren ')'
+        where paren | d<=10     = (:)
+                    | otherwise = \_ -> id
 
 data OrderJob
     = Generate
@@ -90,7 +103,6 @@ data GLStorage
     , slotMap       :: Map String SlotName
     , slotVector    :: Vector (IORef GLSlot)
     , objSeed       :: IORef Int
-    , uniformSetter :: Map GLUniformName InputSetter
     , uniformSetup  :: Map String GLUniform
     , screenSize    :: IORef (Word,Word)
     , pipelines     :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines
@@ -102,7 +114,6 @@ data Object -- internal type
     , objPrimitive  :: Primitive
     , objIndices    :: Maybe (IndexStream Buffer)
     , objAttributes :: Map String (Stream Buffer)
-    , objUniSetter  :: Map GLUniformName InputSetter
     , objUniSetup   :: Map String GLUniform
     , objOrder      :: IORef Int
     , objEnabled    :: IORef Bool
@@ -232,72 +243,7 @@ data GLObjectCommand
 type SetterFun a = a -> IO ()
 
 -- user will provide scalar input data via this type
-data InputSetter
-    = SBool  (SetterFun Bool)
-    | SV2B   (SetterFun V2B)
-    | SV3B   (SetterFun V3B)
-    | SV4B   (SetterFun V4B)
-    | SWord  (SetterFun Word32)
-    | SV2U   (SetterFun V2U)
-    | SV3U   (SetterFun V3U)
-    | SV4U   (SetterFun V4U)
-    | SInt   (SetterFun Int32)
-    | SV2I   (SetterFun V2I)
-    | SV3I   (SetterFun V3I)
-    | SV4I   (SetterFun V4I)
-    | SFloat (SetterFun Float)
-    | SV2F   (SetterFun V2F)
-    | SV3F   (SetterFun V3F)
-    | SV4F   (SetterFun V4F)
-    | SM22F  (SetterFun M22F)
-    | SM23F  (SetterFun M23F)
-    | SM24F  (SetterFun M24F)
-    | SM32F  (SetterFun M32F)
-    | SM33F  (SetterFun M33F)
-    | SM34F  (SetterFun M34F)
-    | SM42F  (SetterFun M42F)
-    | SM43F  (SetterFun M43F)
-    | SM44F  (SetterFun M44F)
-    -- shadow textures
-    | SSTexture1D
-    | SSTexture2D
-    | SSTextureCube
-    | SSTexture1DArray
-    | SSTexture2DArray
-    | SSTexture2DRect
-    -- float textures
-    | SFTexture1D
-    | SFTexture2D           (SetterFun TextureData)
-    | SFTexture3D
-    | SFTextureCube
-    | SFTexture1DArray
-    | SFTexture2DArray
-    | SFTexture2DMS
-    | SFTexture2DMSArray
-    | SFTextureBuffer
-    | SFTexture2DRect
-    -- int textures
-    | SITexture1D
-    | SITexture2D
-    | SITexture3D
-    | SITextureCube
-    | SITexture1DArray
-    | SITexture2DArray
-    | SITexture2DMS
-    | SITexture2DMSArray
-    | SITextureBuffer
-    | SITexture2DRect
-    -- uint textures
-    | SUTexture1D
-    | SUTexture2D
-    | SUTexture3D
-    | SUTextureCube
-    | SUTexture1DArray
-    | SUTexture2DArray
-    | SUTexture2DMS
-    | SUTexture2DMSArray
-    | SUTextureBuffer
-    | SUTexture2DRect
+type InputSetter = GLUniform
 
 -- buffer handling
 {-