1 files changed, 144 insertions, 61 deletions

diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index fbc0f50..071e86b 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -1,8 +1,12 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards       #-}
 module LambdaCube.GL.Util (
     queryUniforms,
     queryStreams,
-    mkUniformSetter,
+    initializeUniform,
     setUniform,
     setVertexAttrib,
     compileShader,
@@ -28,7 +32,9 @@ module LambdaCube.GL.Util (
     compileTexture,
     primitiveToFetchPrimitive,
     primitiveToGLType,
-    inputTypeToTextureTarget
+    inputTypeToTextureTarget,
+    TypeMismatch(..),
+    typeMismatch
 ) where
 
 import Control.Applicative
@@ -43,12 +49,17 @@ import Data.Vector.Unboxed.Mutable (IOVector)
 import qualified Data.Vector.Unboxed.Mutable as MV
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Typeable
+import Data.Dependent.Sum
+import qualified Data.Dependent.Map as DMap
+import Data.Some
 
 import Graphics.GL.Core33
 import LambdaCube.Linear
 import LambdaCube.IR
 import LambdaCube.PipelineSchema
 import LambdaCube.GL.Type
+import LambdaCube.GL.Input.Type
 
 setSampler :: GLint -> Int32 -> IO ()
 setSampler i v = glUniform1i i $ fromIntegral v
@@ -70,67 +81,138 @@ b2w :: Bool -> GLuint
 b2w True = 1
 b2w False = 0
 
-mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)
-mkUniformSetter t@Bool  = do {r <- newIORef 0;                            return $! (GLUniform t r, SBool $!  writeIORef r . b2w)}
-mkUniformSetter t@V2B   = do {r <- newIORef (V2 0 0);                     return $! (GLUniform t r, SV2B $!   writeIORef r . fmap b2w)}
-mkUniformSetter t@V3B   = do {r <- newIORef (V3 0 0 0);                   return $! (GLUniform t r, SV3B $!   writeIORef r . fmap b2w)}
-mkUniformSetter t@V4B   = do {r <- newIORef (V4 0 0 0 0);                 return $! (GLUniform t r, SV4B $!   writeIORef r . fmap b2w)}
-mkUniformSetter t@Word  = do {r <- newIORef 0;                            return $! (GLUniform t r, SWord $!  writeIORef r)}
-mkUniformSetter t@V2U   = do {r <- newIORef (V2 0 0);                     return $! (GLUniform t r, SV2U $!   writeIORef r)}
-mkUniformSetter t@V3U   = do {r <- newIORef (V3 0 0 0);                   return $! (GLUniform t r, SV3U $!   writeIORef r)}
-mkUniformSetter t@V4U   = do {r <- newIORef (V4 0 0 0 0);                 return $! (GLUniform t r, SV4U $!   writeIORef r)}
-mkUniformSetter t@Int   = do {r <- newIORef 0;                            return $! (GLUniform t r, SInt $!   writeIORef r)}
-mkUniformSetter t@V2I   = do {r <- newIORef (V2 0 0);                     return $! (GLUniform t r, SV2I $!   writeIORef r)}
-mkUniformSetter t@V3I   = do {r <- newIORef (V3 0 0 0);                   return $! (GLUniform t r, SV3I $!   writeIORef r)}
-mkUniformSetter t@V4I   = do {r <- newIORef (V4 0 0 0 0);                 return $! (GLUniform t r, SV4I $!   writeIORef r)}
-mkUniformSetter t@Float = do {r <- newIORef 0;                            return $! (GLUniform t r, SFloat $! writeIORef r)}
-mkUniformSetter t@V2F   = do {r <- newIORef (V2 0 0);                     return $! (GLUniform t r, SV2F $!   writeIORef r)}
-mkUniformSetter t@V3F   = do {r <- newIORef (V3 0 0 0);                   return $! (GLUniform t r, SV3F $!   writeIORef r)}
-mkUniformSetter t@V4F   = do {r <- newIORef (V4 0 0 0 0);                 return $! (GLUniform t r, SV4F $!   writeIORef r)}
-mkUniformSetter t@M22F  = do {r <- newIORef (V2 z2 z2);                   return $! (GLUniform t r, SM22F $!  writeIORef r)}
-mkUniformSetter t@M23F  = do {r <- newIORef (V3 z2 z2 z2);                return $! (GLUniform t r, SM23F $!  writeIORef r)}
-mkUniformSetter t@M24F  = do {r <- newIORef (V4 z2 z2 z2 z2);             return $! (GLUniform t r, SM24F $!  writeIORef r)}
-mkUniformSetter t@M32F  = do {r <- newIORef (V2 z3 z3);                   return $! (GLUniform t r, SM32F $!  writeIORef r)}
-mkUniformSetter t@M33F  = do {r <- newIORef (V3 z3 z3 z3);                return $! (GLUniform t r, SM33F $!  writeIORef r)}
-mkUniformSetter t@M34F  = do {r <- newIORef (V4 z3 z3 z3 z3);             return $! (GLUniform t r, SM34F $!  writeIORef r)}
-mkUniformSetter t@M42F  = do {r <- newIORef (V2 z4 z4);                   return $! (GLUniform t r, SM42F $!  writeIORef r)}
-mkUniformSetter t@M43F  = do {r <- newIORef (V3 z4 z4 z4);                return $! (GLUniform t r, SM43F $!  writeIORef r)}
-mkUniformSetter t@M44F  = do {r <- newIORef (V4 z4 z4 z4 z4);             return $! (GLUniform t r, SM44F $!  writeIORef r)}
-mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0);         return $! (GLUniform t r, SFTexture2D $! writeIORef r)}
+instance GLData Bool (GLVector 1 GLuint) where
+    marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w b) (f 1)
+instance GLData (V2 Bool) (GLVector 2 GLuint) where
+    marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
+instance GLData (V3 Bool) (GLVector 3 GLuint) where
+    marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
+instance GLData (V4 Bool) (GLVector 4 GLuint) where
+    marshalUniform _ b = Just $ MarshalGLVector $ \f -> with (b2w <$> b) (f 1 . castPtr)
+instance Uniformable Bool      where uniformContexts _ = contexts $ supports TypeBool
+instance Uniformable (V2 Bool) where uniformContexts _ = contexts $ supports TypeV2B
+instance Uniformable (V3 Bool) where uniformContexts _ = contexts $ supports TypeV3B
+instance Uniformable (V4 Bool) where uniformContexts _ = contexts $ supports TypeV4B
+
+instance GLData Word32      (GLVector 1 GLuint)
+instance GLData (V2 Word32) (GLVector 2 GLuint)
+instance GLData (V3 Word32) (GLVector 3 GLuint)
+instance GLData (V4 Word32) (GLVector 4 GLuint)
+instance Uniformable Word32      where uniformContexts _ = contexts $ supports TypeWord
+instance Uniformable (V2 Word32) where uniformContexts _ = contexts $ supports TypeV2U
+instance Uniformable (V3 Word32) where uniformContexts _ = contexts $ supports TypeV3U
+instance Uniformable (V4 Word32) where uniformContexts _ = contexts $ supports TypeV4U
+
+instance GLData Int32      (GLVector 1 GLint)
+instance GLData (V2 Int32) (GLVector 2 GLint)
+instance GLData (V3 Int32) (GLVector 3 GLint)
+instance GLData (V4 Int32) (GLVector 4 GLint)
+instance Uniformable Int32      where uniformContexts _ = contexts $ supports TypeInt
+instance Uniformable (V2 Int32) where uniformContexts _ = contexts $ supports TypeV2I
+instance Uniformable (V3 Int32) where uniformContexts _ = contexts $ supports TypeV3I
+instance Uniformable (V4 Int32) where uniformContexts _ = contexts $ supports TypeV4I
+
+instance GLData Float      (GLVector 1 GLfloat)
+instance GLData (V2 Float) (GLVector 2 GLfloat)
+instance GLData (V3 Float) (GLVector 3 GLfloat)
+instance GLData (V4 Float) (GLVector 4 GLfloat)
+instance Uniformable Float      where uniformContexts _ = contexts $ supports TypeFloat
+instance Uniformable (V2 Float) where uniformContexts _ = contexts $ supports TypeV2F
+instance Uniformable (V3 Float) where uniformContexts _ = contexts $ supports TypeV3F
+instance Uniformable (V4 Float) where uniformContexts _ = contexts $ supports TypeV4F
+
+instance GLData (V2 V2F) (GLMatrix 2 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V3 V2F) (GLMatrix 3 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V4 V2F) (GLMatrix 4 2 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V2 V3F) (GLMatrix 2 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V3 V3F) (GLMatrix 3 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V4 V3F) (GLMatrix 4 3 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V2 V4F) (GLMatrix 2 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V3 V4F) (GLMatrix 3 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance GLData (V4 V4F) (GLMatrix 4 4 GLfloat) where marshalUniform _ = Just . marshalColumnMajor
+instance Uniformable (V2 V2F) where uniformContexts _ = contexts $ supports TypeM22F
+instance Uniformable (V3 V2F) where uniformContexts _ = contexts $ supports TypeM23F
+instance Uniformable (V4 V2F) where uniformContexts _ = contexts $ supports TypeM24F
+instance Uniformable (V2 V3F) where uniformContexts _ = contexts $ supports TypeM32F
+instance Uniformable (V3 V3F) where uniformContexts _ = contexts $ supports TypeM33F
+instance Uniformable (V4 V3F) where uniformContexts _ = contexts $ supports TypeM34F
+instance Uniformable (V2 V4F) where uniformContexts _ = contexts $ supports TypeM42F
+instance Uniformable (V3 V4F) where uniformContexts _ = contexts $ supports TypeM43F
+instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports TypeM44F
+
+
+instance Uniformable TextureData where uniformContexts _ = DMap.empty -- TODO
+
+mkU :: GLData a c => TypeTag c -> a -> IO GLUniform
+mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a)
+
+initializeUniform :: InputType -> IO GLUniform
+initializeUniform t = case witnessType t of
+
+    Just (This ty) -> case ty of
+        TypeBool  -> mkU ty False
+        TypeV2B   -> mkU ty (V2 False False)
+        TypeV3B   -> mkU ty (V3 False False False)
+        TypeV4B   -> mkU ty (V4 False False False False)
+        TypeWord  -> mkU ty (0::Word32)
+        TypeV2U   -> mkU ty (V2 0 0 :: V2 Word32)
+        TypeV3U   -> mkU ty (V3 0 0 0 :: V3 Word32)
+        TypeV4U   -> mkU ty (V4 0 0 0 0 :: V4 Word32)
+        TypeInt   -> mkU ty (0::Int32)
+        TypeV2I   -> mkU ty (V2 0 0 :: V2 Int32)
+        TypeV3I   -> mkU ty (V3 0 0 0 :: V3 Int32)
+        TypeV4I   -> mkU ty (V4 0 0 0 0 :: V4 Int32)
+        TypeFloat -> mkU ty (0::Float)
+        TypeV2F   -> mkU ty (V2 0 0 :: V2 Float)
+        TypeV3F   -> mkU ty (V3 0 0 0 :: V3 Float)
+        TypeV4F   -> mkU ty (V4 0 0 0 0 :: V4 Float)
+        TypeM22F -> mkU ty (V2 z2 z2)
+        TypeM23F -> mkU ty (V3 z2 z2 z2)
+        TypeM24F -> mkU ty (V4 z2 z2 z2 z2)
+        TypeM32F -> mkU ty (V2 z3 z3)
+        TypeM33F -> mkU ty (V3 z3 z3 z3)
+        TypeM34F -> mkU ty (V4 z3 z3 z3 z3)
+        TypeM42F -> mkU ty (V2 z4 z4)
+        TypeM43F -> mkU ty (V3 z4 z4 z4)
+        TypeM44F -> mkU ty (V4 z4 z4 z4 z4)
+
+    Nothing -> case t of
+        FTexture2D -> GLUniform t <$> newIORef (TextureData 0)
+        _          -> fail $ "initializeUniform: " ++ show t
+
+
+data TypeMismatch c a = TypeMismatch
+
+instance (Typeable c, Typeable a) => Show (TypeMismatch c a) where
+    showsPrec d ty =
+            paren '('
+            . mappend "TypeMismatch @"
+            . showsPrec 11 (typeRep $ ctx ty)
+            . mappend " @"
+            . showsPrec 0 (typeRep ty)
+            . paren ')'
+        where
+            ctx :: ty c a -> Proxy c
+            ctx _ = Proxy
+            paren | d<=10     = (:)
+                  | otherwise = \_ -> id
+
+instance (Typeable c, Typeable a) => Exception (TypeMismatch c a)
+
+typeMismatch :: ctx c -> ref a -> TypeMismatch c a
+typeMismatch _ _ = TypeMismatch
 
 -- sets value based uniforms only (does not handle textures)
-setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()
+setUniform :: GLint -> TypeTag c -> IO (GLUniformValue c) -> IO ()
 setUniform i ty ref = do
-    v <- readIORef ref
-    let false = fromIntegral GL_FALSE
-    with v $ \p -> case ty of
-        Bool        -> glUniform1uiv i 1 (castPtr p)
-        V2B         -> glUniform2uiv i 1 (castPtr p)
-        V3B         -> glUniform3uiv i 1 (castPtr p)
-        V4B         -> glUniform4uiv i 1 (castPtr p)
-        Word        -> glUniform1uiv i 1 (castPtr p)
-        V2U         -> glUniform2uiv i 1 (castPtr p)
-        V3U         -> glUniform3uiv i 1 (castPtr p)
-        V4U         -> glUniform4uiv i 1 (castPtr p)
-        Int         -> glUniform1iv i 1 (castPtr p)
-        V2I         -> glUniform2iv i 1 (castPtr p)
-        V3I         -> glUniform3iv i 1 (castPtr p)
-        V4I         -> glUniform4iv i 1 (castPtr p)
-        Float       -> glUniform1fv i 1 (castPtr p)
-        V2F         -> glUniform2fv i 1 (castPtr p)
-        V3F         -> glUniform3fv i 1 (castPtr p)
-        V4F         -> glUniform4fv i 1 (castPtr p)
-        M22F        -> glUniformMatrix2fv   i 1 false (castPtr p)
-        M23F        -> glUniformMatrix2x3fv i 1 false (castPtr p)
-        M24F        -> glUniformMatrix2x4fv i 1 false (castPtr p)
-        M32F        -> glUniformMatrix3x2fv i 1 false (castPtr p)
-        M33F        -> glUniformMatrix3fv   i 1 false (castPtr p)
-        M34F        -> glUniformMatrix3x4fv i 1 false (castPtr p)
-        M42F        -> glUniformMatrix4x2fv i 1 false (castPtr p)
-        M43F        -> glUniformMatrix4x3fv i 1 false (castPtr p)
-        M44F        -> glUniformMatrix4fv   i 1 false (castPtr p)
-        FTexture2D  -> return () --putStrLn $ "TODO: setUniform FTexture2D"
-        _   -> fail $ "internal error (setUniform)! - " ++ show ty
+    GLUniformValue v <- ref
+    let false = GL_FALSE
+    case marshalUniform (glABI ty) v of
+        Just (MarshalGLVector withU) -> withU $ \n ptr ->
+            case glUniform ty of GLVector f -> f i n ptr
+        Just (MarshalGLMatrix withU) -> withU $ \n isRowMajor ptr ->
+            case glUniform ty of GLMatrix f -> f i n isRowMajor ptr
+        Nothing -> throwIO (typeMismatch ty ref)
 
 -- attribute functions
 queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType)
@@ -605,6 +687,7 @@ compileTexture txDescriptor = do
             , textureMaxLevel   = txMaxLevel
             } = txDescriptor
 
+        txSetup :: Num a => GLenum -> TextureDataType -> IO (a,GLenum)
         txSetup txTarget dTy = do
             let internalFormat  = fromIntegral $ textureDataTypeToGLType txSemantic dTy
                 dataFormat      = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy