Representation-agnostic matrix/vector pipeline inputs.

6 files changed, 895 insertions, 328 deletions

diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal
index d9f569d..d265b70 100644
--- a/lambdacube-gl.cabal
+++ b/lambdacube-gl.cabal
@@ -44,6 +44,7 @@ library
     LambdaCube.GL.Backend
     LambdaCube.GL.Data
     LambdaCube.GL.Input
+    LambdaCube.GL.Input.Type
     LambdaCube.GL.Mesh
     LambdaCube.GL.Type
     LambdaCube.GL.Util
@@ -58,7 +59,9 @@ library
     vector-algorithms >=0.7 && <0.8,
     JuicyPixels >=3.2.8 && <3.4,
     OpenGLRaw >=3.2 && <4,
-    lambdacube-ir == 0.3.*
+    lambdacube-ir == 0.3.*,
+    dependent-sum >= 0.4,
+    dependent-map >= 0.2
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index c5e3190..08f10d4 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -30,6 +30,7 @@ import LambdaCube.Linear
 import LambdaCube.IR hiding (streamType)
 import qualified LambdaCube.IR as IR
 
+import LambdaCube.GL.Input.Type
 import LambdaCube.GL.Type
 import LambdaCube.GL.Util
 
@@ -487,7 +488,9 @@ createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ s
                   , let u = topUni n
                   , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
                   ]
-        uniInputType (GLUniform ty _) = ty
+        uniInputType (GLTypedUniform ty _) = unwitnessType ty
+        uniInputType (GLUniform ty _)      = ty
+
 
     -- object attribute stream commands
     streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
@@ -764,7 +767,8 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
                                                             setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
                                                             glDrawElements mode count typ indicesPtr
                                                             modifyIORef glDrawCallCounterRef succ
-        GLSetUniform idx (GLUniform ty ref)             -> setUniform idx ty ref
+        GLSetUniform idx (GLTypedUniform ty ref)        -> setUniform idx ty (readIORef ref)
+        GLSetUniform idx (GLUniform ty ref)             -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
         GLBindTexture txTarget tuRef (GLUniform _ ref)  -> do
                                                             txObjVal <- readIORef ref
                                                             -- HINT: ugly and hacky
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 5d2a49e..bd46fe0 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,9 +1,16 @@
 {-# LANGUAGE BangPatterns, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 module LambdaCube.GL.Input where
 
 import Control.Applicative
 import Control.Exception
 import Control.Monad
+import Control.Monad.Reader
 import Control.Monad.Writer
 import Data.Maybe
 import Data.IORef
@@ -12,7 +19,9 @@ import Data.IntMap (IntMap)
 import Data.Vector (Vector,(//),(!))
 import Data.Word
 import Data.String
+import Data.Typeable
 import Foreign
+import qualified Data.Dependent.Map as DMap
 import qualified Data.IntMap as IM
 import qualified Data.Set as S
 import qualified Data.Map as Map
@@ -23,11 +32,12 @@ import qualified Data.ByteString.Char8 as SB
 
 import Graphics.GL.Core33
 
+import LambdaCube.GL.Input.Type
+import LambdaCube.GL.Type as T
+import LambdaCube.GL.Util
 import LambdaCube.IR as IR
 import LambdaCube.Linear as IR
 import LambdaCube.PipelineSchema
-import LambdaCube.GL.Type as T
-import LambdaCube.GL.Util
 
 import qualified LambdaCube.IR as IR
 
@@ -43,19 +53,19 @@ schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.emp
         Just v  -> v
         Nothing -> error "internal error (schemaFromPipeline)"
 
-mkUniform :: [(String,InputType)] -> IO (Map GLUniformName InputSetter, Map String GLUniform)
+mkUniform :: [(String,InputType)] -> IO (Map String GLUniform)
 mkUniform l = do
-    unisAndSetters <- forM l $ \(n,t) -> do
-        (uni, setter) <- mkUniformSetter t
-        return ((n,uni),(fromString n,setter))
-    let (unis,setters) = unzip unisAndSetters
-    return (Map.fromList setters, Map.fromList unis)
+    unis <- forM l $ \(n,t) -> do
+        uni <- initializeUniform t
+        return (n,uni)
+    return (Map.fromList unis)
+
 
 allocStorage :: PipelineSchema -> IO GLStorage
 allocStorage sch = do
     let sm  = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..]
         len = Map.size sm
-    (setters,unis) <- mkUniform $ Map.toList $ uniforms sch
+    unis <- mkUniform $ Map.toList $ uniforms sch
     seed <- newIORef 0
     slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
     size <- newIORef (0,0)
@@ -65,7 +75,6 @@ allocStorage sch = do
         , slotMap       = sm
         , slotVector    = slotV
         , objSeed       = seed
-        , uniformSetter = setters
         , uniformSetup  = unis
         , screenSize    = size
         , pipelines     = ppls
@@ -102,14 +111,15 @@ addObject input slotName prim indices attribs uniformNames = do
     enabled <- newIORef True
     index <- readIORef seed
     modifyIORef seed (1+)
-    (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)]
+    unis <- mkUniform [(n,t) | n <- uniformNames,
+                                         let t = fromMaybe (error $ "missing uniform: " ++ n)
+                                                   $ Map.lookup n (uniforms sch)]
     cmdsRef <- newIORef (V.singleton V.empty)
     let obj = Object
             { objSlot       = slotIdx
             , objPrimitive  = prim
             , objIndices    = indices
             , objAttributes = attribs
-            , objUniSetter  = setters
             , objUniSetup   = unis
             , objOrder      = order
             , objEnabled    = enabled
@@ -154,8 +164,11 @@ setObjectOrder p obj i = do
     writeIORef (objOrder obj) i
     modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
 
+uniformSetter :: GLStorage -> Map String InputSetter
+uniformSetter = uniformSetup
+
 objectUniformSetter :: Object -> Map GLUniformName InputSetter
-objectUniformSetter = objUniSetter
+objectUniformSetter = objUniSetup
 
 setScreenSize :: GLStorage -> Word -> Word -> IO ()
 setScreenSize p w h = writeIORef (screenSize p) (w,h)
@@ -212,7 +225,8 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
                   , let u = Map.findWithDefault (topUni n) n objUnis
                   , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
                   ]
-        uniInputType (GLUniform ty _) = ty
+        uniInputType (GLTypedUniform ty _) = unwitnessType ty
+        uniInputType (GLUniform ty _)      = ty
 
     -- object attribute stream commands
     objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]
@@ -252,187 +266,177 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
             -- constant generic attribute
             constAttr -> GLSetVertexAttrib i constAttr
 
-nullSetter :: GLUniformName -> String -> a -> IO ()
-nullSetter n t _ = return ()
---nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show n ++ " :: " ++ t
-
-uniformBool  :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Bool
-uniformV2B   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2B
-uniformV3B   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3B
-uniformV4B   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4B
-
-uniformWord  :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Word32
-uniformV2U   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2U
-uniformV3U   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3U
-uniformV4U   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4U
-
-uniformInt   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Int32
-uniformV2I   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2I
-uniformV3I   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3I
-uniformV4I   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4I
-
-uniformFloat :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Float
-uniformV2F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2F
-uniformV3F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3F
-uniformV4F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4F
-
-uniformM22F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M22F
-uniformM23F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M23F
-uniformM24F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M24F
-uniformM32F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M32F
-uniformM33F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M33F
-uniformM34F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M34F
-uniformM42F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M42F
-uniformM43F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M43F
-uniformM44F   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M44F
-
-uniformFTexture2D   :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun TextureData
-
-uniformBool n is = case Map.lookup n is of
-    Just (SBool fun)    -> fun
-    _   -> nullSetter n "Bool"
-
-uniformV2B n is = case Map.lookup n is of
-    Just (SV2B fun)    -> fun
-    _   -> nullSetter n "V2B"
-
-uniformV3B n is = case Map.lookup n is of
-    Just (SV3B fun)    -> fun
-    _   -> nullSetter n "V3B"
+newtype UniM a = UniM (ReaderT (Map GLUniformName GLUniform) (Writer [IO ()]) a)
+deriving instance Functor UniM
+deriving instance Applicative UniM
+deriving instance Monad UniM
+deriving instance MonadReader (Map String GLUniform) UniM
+deriving instance MonadWriter [IO ()] UniM
+
+
+(@=) :: (Typeable a, Uniformable a) => String -> IO a -> UniM ()
+name @= val = do
+    u <- do
+        us <- ask
+        return $ us Map.! name
+    case u of
+
+        GLTypedUniform ty ref -> do
+            case DMap.lookup ty (uniformContexts val) of
+                Just UniformContext -> do
+                    tell [val >>= writeIORef ref . GLUniformValue]
+                Nothing -> do
+                    tell [throwIO $ typeMismatch ty ref]
+
+        GLUniform FTexture2D ref -> case withTypes val ref <$> eqT of
+            Just Refl -> tell [val >>= writeIORef ref]
+            Nothing -> tell [ Prelude.putStrLn $ "WARNING: Texture2D variable "
+                                                 ++ show name
+                                                 ++ " cannot recieve value " ++ show (typeRep val)
+                            , throwIO $ typeMismatch ref val
+                            ]
+
+        GLUniform ty _ -> tell [Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show name ++ " :: " ++ show ty]
 
-uniformV4B n is = case Map.lookup n is of
-    Just (SV4B fun)    -> fun
-    _   -> nullSetter n "V4B"
-
-uniformWord n is = case Map.lookup n is of
-    Just (SWord fun)    -> fun
-    _   -> nullSetter n "Word"
-
-uniformV2U n is = case Map.lookup n is of
-    Just (SV2U fun)    -> fun
-    _   -> nullSetter n "V2U"
-
-uniformV3U n is = case Map.lookup n is of
-    Just (SV3U fun)    -> fun
-    _   -> nullSetter n "V3U"
-
-uniformV4U n is = case Map.lookup n is of
-    Just (SV4U fun)    -> fun
-    _   -> nullSetter n "V4U"
-
-uniformInt n is = case Map.lookup n is of
-    Just (SInt fun)    -> fun
-    _   -> nullSetter n "Int"
-
-uniformV2I n is = case Map.lookup n is of
-    Just (SV2I fun)    -> fun
-    _   -> nullSetter n "V2I"
-
-uniformV3I n is = case Map.lookup n is of
-    Just (SV3I fun)    -> fun
-    _   -> nullSetter n "V3I"
-
-uniformV4I n is = case Map.lookup n is of
-    Just (SV4I fun)    -> fun
-    _   -> nullSetter n "V4I"
-
-uniformFloat n is = case Map.lookup n is of
-    Just (SFloat fun)    -> fun
-    _   -> nullSetter n "Float"
-
-uniformV2F n is = case Map.lookup n is of
-    Just (SV2F fun)    -> fun
-    _   -> nullSetter n "V2F"
-
-uniformV3F n is = case Map.lookup n is of
-    Just (SV3F fun)    -> fun
-    _   -> nullSetter n "V3F"
-
-uniformV4F n is = case Map.lookup n is of
-    Just (SV4F fun)    -> fun
-    _   -> nullSetter n "V4F"
-
-uniformM22F n is = case Map.lookup n is of
-    Just (SM22F fun)    -> fun
-    _   -> nullSetter n "M22F"
-
-uniformM23F n is = case Map.lookup n is of
-    Just (SM23F fun)    -> fun
-    _   -> nullSetter n "M23F"
-
-uniformM24F n is = case Map.lookup n is of
-    Just (SM24F fun)    -> fun
-    _   -> nullSetter n "M24F"
-
-uniformM32F n is = case Map.lookup n is of
-    Just (SM32F fun)    -> fun
-    _   -> nullSetter n "M32F"
-
-uniformM33F n is = case Map.lookup n is of
-    Just (SM33F fun)    -> fun
-    _   -> nullSetter n "M33F"
-
-uniformM34F n is = case Map.lookup n is of
-    Just (SM34F fun)    -> fun
-    _   -> nullSetter n "M34F"
-
-uniformM42F n is = case Map.lookup n is of
-    Just (SM42F fun)    -> fun
-    _   -> nullSetter n "M42F"
-
-uniformM43F n is = case Map.lookup n is of
-    Just (SM43F fun)    -> fun
-    _   -> nullSetter n "M43F"
-
-uniformM44F n is = case Map.lookup n is of
-    Just (SM44F fun)    -> fun
-    _   -> nullSetter n "M44F"
-
-uniformFTexture2D n is = case Map.lookup n is of
-    Just (SFTexture2D fun)    -> fun
-    _   -> nullSetter n "FTexture2D"
-
-type UniM = Writer [Map GLUniformName InputSetter -> IO ()]
-
-class UniformSetter a where
-  (@=) :: GLUniformName -> IO a -> UniM ()
-
-setUniM :: (n -> Map GLUniformName InputSetter -> a -> IO ()) -> n -> IO a -> UniM ()
-setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act]
-
-instance UniformSetter Bool   where (@=) = setUniM uniformBool
-instance UniformSetter V2B    where (@=) = setUniM uniformV2B
-instance UniformSetter V3B    where (@=) = setUniM uniformV3B
-instance UniformSetter V4B    where (@=) = setUniM uniformV4B
-instance UniformSetter Word32 where (@=) = setUniM uniformWord
-instance UniformSetter V2U    where (@=) = setUniM uniformV2U
-instance UniformSetter V3U    where (@=) = setUniM uniformV3U
-instance UniformSetter V4U    where (@=) = setUniM uniformV4U
-instance UniformSetter Int32  where (@=) = setUniM uniformInt
-instance UniformSetter V2I    where (@=) = setUniM uniformV2I
-instance UniformSetter V3I    where (@=) = setUniM uniformV3I
-instance UniformSetter V4I    where (@=) = setUniM uniformV4I
-instance UniformSetter Float  where (@=) = setUniM uniformFloat
-instance UniformSetter V2F    where (@=) = setUniM uniformV2F
-instance UniformSetter V3F    where (@=) = setUniM uniformV3F
-instance UniformSetter V4F    where (@=) = setUniM uniformV4F
-instance UniformSetter M22F   where (@=) = setUniM uniformM22F
-instance UniformSetter M23F   where (@=) = setUniM uniformM23F
-instance UniformSetter M24F   where (@=) = setUniM uniformM24F
-instance UniformSetter M32F   where (@=) = setUniM uniformM32F
-instance UniformSetter M33F   where (@=) = setUniM uniformM33F
-instance UniformSetter M34F   where (@=) = setUniM uniformM34F
-instance UniformSetter M42F   where (@=) = setUniM uniformM42F
-instance UniformSetter M43F   where (@=) = setUniM uniformM43F
-instance UniformSetter M44F   where (@=) = setUniM uniformM44F
-instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D
 
 updateUniforms :: GLStorage -> UniM a -> IO ()
-updateUniforms storage m = sequence_ l where
-  setters = uniformSetter storage
-  l = map ($ setters) $ execWriter m
+updateUniforms storage (UniM m) = sequence_ l where
+  setters = uniformSetup storage
+  l = execWriter $ runReaderT m setters
 
 updateObjectUniforms :: Object -> UniM a -> IO ()
-updateObjectUniforms object m = sequence_ l where
+updateObjectUniforms object (UniM m) = sequence_ l where
   setters = objectUniformSetter object
-  l = map ($ setters) $ execWriter m
+  l = execWriter $ runReaderT m setters
+
+-- | Set a uniform ref.
+setGLUniform :: Typeable a =>
+    (forall v. Typeable v => TypeTag v -> Maybe (UniformContext a v))
+    -> String       -- ^ For warning messages, name of uniform.
+    -> GLUniform -- ^ Uniform ref to set.
+    -> a         -- ^ Value to store.
+    -> IO ()
+setGLUniform resolv name u val = case u of
+        GLTypedUniform ty ref -> do
+            case resolv ty of
+                Just UniformContext -> writeIORef ref $ GLUniformValue val
+                Nothing -> warn $ unwords [ "Cannot set", show $ unwitnessType ty
+                                          , "uniform", name
+                                          , "to", show (typeOf val)
+                                          , "value." ]
+
+        GLUniform textureType ref -> case withTypes (Just val) ref <$> eqT of
+            Just Refl -> writeIORef ref val
+            Nothing -> warn $ unwords [ show textureType
+                                      , "uniform", name
+                                      , "only accepts values of type TextureData." ]
+    where warn s = putStrLn $ "WARNING: " ++ s
+
+-- | Lookup and set a Uniform ref.
+setUniformRef :: ( Typeable a
+                 , Show name, Ord name
+                 ) => (forall v. Typeable v => TypeTag v -> Maybe (UniformContext a v))
+                   -> name
+                   -> Map name GLUniform
+                   -> a
+                   -> IO ()
+setUniformRef resolv name us val = case Map.lookup name us of
+    Nothing -> warn $ "unknown uniform: " ++ show name
+    Just u -> setGLUniform resolv (show name) u val
+    where warn s = putStrLn $ "WARNING: " ++ s
+
+uniformOf :: (Show name, Ord name, GLData a have) =>
+    TypeTag have
+    -> name
+    -> Map name GLUniform
+    -> a
+    -> IO ()
+uniformOf have = setUniformRef $ knownContext have
+
+uniform :: (Typeable a, Show name, Ord name, Uniformable a) =>
+                 name -> Map name GLUniform -> a -> IO ()
+uniform n o a = setUniformRef (resolveContext a) n o a
+
+
+uniformFTexture2D :: SB.ByteString -> Map GLUniformName GLUniform -> TextureData -> IO ()
+uniformFTexture2D =
+    -- TODO: Check that the uniform is of the expected FTexture2D type.
+    uniform . SB.unpack
+
+uniformBool :: (Show name, Ord name) => name -> Map name GLUniform -> Bool -> IO ()
+uniformV2B :: (Show name, Ord name, GLData a (GLVector 2 Word32)) => name -> Map name GLUniform -> a -> IO ()
+uniformV3B :: (Show name, Ord name, GLData a (GLVector 3 Word32)) => name -> Map name GLUniform -> a -> IO ()
+uniformV4B :: (Show name, Ord name, GLData a (GLVector 4 Word32)) => name -> Map name GLUniform -> a -> IO ()
+uniformBool = uniformOf TypeBool
+uniformV2B = uniformOf TypeV2B
+uniformV3B = uniformOf TypeV3B
+uniformV4B = uniformOf TypeV4B
+
+uniformWord :: (Show name, Ord name) => name -> Map name GLUniform -> Word32 -> IO ()
+uniformV2U :: (Typeable f, GLData (f Word32) (GLVector 2 Word32)) =>
+              String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
+uniformV3U :: (Typeable f, GLData (f Word32) (GLVector 3 Word32)) =>
+              String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
+uniformV4U :: (Typeable f, GLData (f Word32) (GLVector 4 Word32)) =>
+              String -> Map GLUniformName GLUniform -> f Word32 -> IO ()
+uniformWord = uniformOf TypeWord
+uniformV2U = uniformOf TypeV2U
+uniformV3U = uniformOf TypeV3U
+uniformV4U = uniformOf TypeV4U
+
+uniformFloat :: (Show name, Ord name) => name -> Map name GLUniform -> Float -> IO ()
+uniformV2F :: (Typeable f, GLData (f Float) (GLVector 2 Float)) =>
+              String -> Map GLUniformName GLUniform -> f Float -> IO ()
+uniformV3F :: (Typeable f, GLData (f Float) (GLVector 3 Float)) =>
+              String -> Map GLUniformName GLUniform -> f Float -> IO ()
+uniformV4F :: (Typeable f, GLData (f Float) (GLVector 4 Float)) =>
+              String -> Map GLUniformName GLUniform -> f Float -> IO ()
+uniformFloat = uniformOf TypeFloat
+uniformV2F = setUniformRef (knownContext TypeV2F)
+uniformV3F = setUniformRef (knownContext TypeV3F)
+uniformV4F = setUniformRef (knownContext TypeV4F)
+
+uniformInt :: (Show name, Ord name) => name -> Map name GLUniform -> Int32 -> IO ()
+uniformV2I :: (Typeable f, GLData (f Int32) (GLVector 2 Int32)) =>
+              String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
+uniformV3I :: (Typeable f, GLData (f Int32) (GLVector 3 Int32)) =>
+              String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
+uniformV4I :: (Typeable f, GLData (f Int32) (GLVector 4 Int32)) =>
+              String -> Map GLUniformName GLUniform -> f Int32 -> IO ()
+uniformInt = uniformOf TypeInt
+uniformV2I = uniformOf TypeV2I
+uniformV3I = uniformOf TypeV3I
+uniformV4I = uniformOf TypeV4I
+
+{-
+Note: This works to infer the type Float for literals without fixing the matrix type:
+
+    type family MatrixComponent m where
+        MatrixComponent (f (g c)) = c
+        MatrixComponent (f c) = c
+
+    uniformM44F :: ( MatrixComponent a ~ Float , GLData a (GLMatrix 4 4 Float))
+                    => String -> Map String GLUniform -> a -> IO ()
+
+However, it breaks the ability to partially apply without a type signature.
+Therefore, I'm forcing LambdaCube's internal matrix types for uniformM*
+functions.
+-}
+uniformM22F :: (Show name, Ord name) => name -> Map name GLUniform -> M22F -> IO ()
+uniformM23F :: (Show name, Ord name) => name -> Map name GLUniform -> M23F -> IO ()
+uniformM24F :: (Show name, Ord name) => name -> Map name GLUniform -> M24F -> IO ()
+uniformM32F :: (Show name, Ord name) => name -> Map name GLUniform -> M32F -> IO ()
+uniformM33F :: (Show name, Ord name) => name -> Map name GLUniform -> M33F -> IO ()
+uniformM34F :: (Show name, Ord name) => name -> Map name GLUniform -> M34F -> IO ()
+uniformM42F :: (Show name, Ord name) => name -> Map name GLUniform -> M42F -> IO ()
+uniformM43F :: (Show name, Ord name) => name -> Map name GLUniform -> M43F -> IO ()
+uniformM44F :: (Show name, Ord name) => name -> Map name GLUniform -> M44F -> IO ()
+uniformM22F = uniformOf TypeM22F
+uniformM23F = uniformOf TypeM23F
+uniformM24F = uniformOf TypeM24F
+uniformM32F = uniformOf TypeM32F
+uniformM33F = uniformOf TypeM33F
+uniformM34F = uniformOf TypeM34F
+uniformM42F = uniformOf TypeM42F
+uniformM43F = uniformOf TypeM43F
+uniformM44F = uniformOf TypeM44F
diff --git a/src/LambdaCube/GL/Input/Type.hs b/src/LambdaCube/GL/Input/Type.hs
new file mode 100644
index 0000000..eaadce5
--- /dev/null
+++ b/src/LambdaCube/GL/Input/Type.hs
@@ -0,0 +1,527 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+
+-- | Module : LambdaCube.GL.Input.Type
+--
+-- This module provides types for describing the matrix and vector ABI for
+-- passing vectors and matrices to OpenGL shaders as "uniforms".
+--
+-- For a given shader input 'InputType', there is associated (via
+-- 'witnessType') a type-level description of the GL calls necessary to upload
+-- pointers to the GPU.
+--
+-- To make it so that a Haskell value can be uploaded, instances of 'GLData'
+-- and 'Uniformable' should be provided.  These describe how to marshall a
+-- haskell type into a suitable pointer for a given context.
+--
+-- For example, users of the hmatrix package, might find these instances useful:
+--
+-- > import GHC.TypeLits
+-- > import LambdaCube.GL.Input.Type
+-- > import Numeric.LinearAlgebra
+-- > import Numeric.LinearAlgebra.Devel
+-- >
+-- > instance Uniformable (Matrix Float) where
+-- >     uniformContexts _ = contexts floatMatrices
+-- >
+-- > instance Uniformable (Vector Float) where
+-- >     uniformContexts _ = contexts $ do
+-- >         supports TypeFloat
+-- >         supports TypeV2F
+-- >         supports TypeV3F
+-- >         supports TypeV4F
+-- >
+-- > instance (KnownNat r, KnownNat c) => GLData (Matrix Float) (GLMatrix r c Float) where
+-- >     marshalUniform abi mat = case matrixDimensions abi of
+-- >         (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing
+-- >               | fromIntegral (natVal c) /= cols mat -> Nothing
+-- >         _ -> let isRowOrder = case orderOf mat of
+-- >                         RowMajor    -> 1
+-- >                         ColumnMajor -> 0
+-- >              in Just $ MarshalGLMatrix
+-- >                      $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr)
+-- >
+-- > instance KnownNat n => GLData (Vector Float) (GLVector n Float) where
+-- >     marshalUniform abi vec
+-- >         | natVal (vectorLength abi) /= fromIntegral (size vec) = Nothing
+-- >         | otherwise = Just $ MarshalGLVector
+-- >                            $ \f -> apply vec (\ptr -> f 1 ptr) (\n ptr -> ptr)
+module LambdaCube.GL.Input.Type where
+
+import Control.Monad
+import Control.Monad.State
+import Data.Functor.Identity
+import Data.Typeable
+import Foreign
+import GHC.TypeLits
+
+import Data.Dependent.Map as DMap
+import Data.Dependent.Sum
+import Data.GADT.Compare
+
+import Graphics.GL.Core33
+import LambdaCube.IR (InputType(..))
+
+
+-- | A 'Uniformable' type /a/ has a runtime dictionary of available instances
+-- of 'GLData' /a/ /c/.  For example, if you have a matrix type that does
+-- not include type-level dimension information,  you may want to set
+--
+-- > uniformContexts _ = contexts floatMatrices
+--
+-- Use 'contexts' and 'supports' to list individual instances.  Typically, for
+-- dimension-specific types, 'uniformContexts' will be a singleton map.
+--
+-- Note that if a context is known at compile-time, then the compiler can
+-- lookup an appropriate instance.  This class is provided so that the lookup
+-- can happen at runtime instead.
+class Uniformable a where
+    uniformContexts :: proxy a -> DMap TypeTag (UniformContext a)
+
+-- | A light wrapper over 'execState' to make it easier to specify the
+-- 'uniformContexts' DMap.
+contexts :: State (DMap TypeTag (UniformContext a)) () -> DMap TypeTag (UniformContext a)
+contexts = flip execState DMap.empty
+
+-- | Inserts an instance into the 'uniformContexts' DMap.  See 'floatMatrices'
+-- for an example.
+supports :: GLData a c => TypeTag c -> State (DMap TypeTag (UniformContext a)) ()
+supports ty = modify' (DMap.insert ty UniformContext)
+
+
+-- | A set of GLData instances for all Float matrix types.  It is defined:
+--
+-- > floatMatrices = do
+-- >     supports TypeM22F
+-- >     supports TypeM23F
+-- >     supports TypeM24F
+-- >     supports TypeM32F
+-- >     supports TypeM33F
+-- >     supports TypeM34F
+-- >     supports TypeM42F
+-- >     supports TypeM43F
+-- >     supports TypeM44F
+--
+-- Use 'contexts' to turn this into a 'DMap' suitable to implemented 'uniformContexts'.
+floatMatrices :: (GLData a (GLMatrix 2 2 Float),
+                  GLData a (GLMatrix 2 3 Float),
+                  GLData a (GLMatrix 2 4 Float),
+                  GLData a (GLMatrix 3 2 Float),
+                  GLData a (GLMatrix 3 3 Float),
+                  GLData a (GLMatrix 3 4 Float),
+                  GLData a (GLMatrix 4 2 Float),
+                  GLData a (GLMatrix 4 3 Float),
+                  GLData a (GLMatrix 4 4 Float)) =>
+                 State (DMap TypeTag (UniformContext a)) ()
+floatMatrices = do
+    supports TypeM22F
+    supports TypeM23F
+    supports TypeM24F
+    supports TypeM32F
+    supports TypeM33F
+    supports TypeM34F
+    supports TypeM42F
+    supports TypeM43F
+    supports TypeM44F
+
+-- | A runtime witness for an instance of 'GLData' /a/ /c/.  To obtain a
+-- witness given a specific context 'TypeTag' /c/, perform a lookup into the
+-- 'uniformContexts' DMap.
+data UniformContext a c = GLData a c => UniformContext
+
+-- | Type-check (at runtime) a specific GLData instance.
+knownContext :: (GLData a have, Typeable have, Typeable want) => TypeTag have -> TypeTag want -> Maybe (UniformContext a want)
+knownContext known ty = do
+    Refl <- withTypes known ty <$> eqT
+    return UniformContext
+
+-- | Lookup a GLData instance, given a Uniformable value.
+resolveContext :: Uniformable a => a -> TypeTag want -> Maybe (UniformContext a want)
+resolveContext val ty = DMap.lookup ty . uniformContexts .  mkproxy $ val
+ where
+    mkproxy :: val -> Proxy val
+    mkproxy _ = Proxy
+
+
+-- | This type classifies a shader "uniform" input based on the OpenGL calls
+-- necessary to upload it to the GPU.  The primitive types are described as if
+-- they are 1-vectors.  Vector types are described by 'GLVector' and matrix
+-- types are described by 'GLMatrix'.
+--
+-- Currently, Texture uniforms are not described and there is a, probably
+-- useless, run-time distinction between Bool and Word which have the same
+-- OpenGL ABI.
+--
+-- Use 'witnessType' to obtain this from a runtime-only value.
+data TypeTag t where
+    TypeBool  :: TypeTag (GLVector 1 Word32)
+    TypeV2B   :: TypeTag (GLVector 2 Word32)
+    TypeV3B   :: TypeTag (GLVector 3 Word32)
+    TypeV4B   :: TypeTag (GLVector 4 Word32)
+    TypeWord  :: TypeTag (GLVector 1 Word32)
+    TypeV2U   :: TypeTag (GLVector 2 Word32)
+    TypeV3U   :: TypeTag (GLVector 3 Word32)
+    TypeV4U   :: TypeTag (GLVector 4 Word32)
+
+    TypeInt   :: TypeTag (GLVector 1 Int32)
+    TypeV2I   :: TypeTag (GLVector 2 Int32)
+    TypeV3I   :: TypeTag (GLVector 3 Int32)
+    TypeV4I   :: TypeTag (GLVector 4 Int32)
+
+    TypeFloat :: TypeTag (GLVector 1 Float)
+    TypeV2F   :: TypeTag (GLVector 2 Float)
+    TypeV3F   :: TypeTag (GLVector 3 Float)
+    TypeV4F   :: TypeTag (GLVector 4 Float)
+
+    TypeM22F  :: TypeTag (GLMatrix 2 2 Float)
+    TypeM23F  :: TypeTag (GLMatrix 3 2 Float)
+    TypeM24F  :: TypeTag (GLMatrix 4 2 Float)
+    TypeM32F  :: TypeTag (GLMatrix 2 3 Float)
+    TypeM33F  :: TypeTag (GLMatrix 3 3 Float)
+    TypeM34F  :: TypeTag (GLMatrix 4 3 Float)
+    TypeM42F  :: TypeTag (GLMatrix 2 4 Float)
+    TypeM43F  :: TypeTag (GLMatrix 3 4 Float)
+    TypeM44F  :: TypeTag (GLMatrix 4 4 Float)
+
+instance GEq TypeTag where
+    geq a b = do
+        Refl <- geq (glABI a) (glABI b)
+        guard $ isBoolTag a == isBoolTag b
+        return Refl
+
+instance GCompare TypeTag where
+    gcompare a b = case compare (isBoolTag a) (isBoolTag b) of
+        LT -> GLT
+        EQ -> gcompare (glABI a) (glABI b)
+        GT -> GGT
+
+-- | This function provides the only term-only information in the 'TypeTag'
+-- type.  Booleans are treated similarly to unsigned ints by OpenGL, so the
+-- distinction is not made in the type of the tag and the 'GEq' instance of
+-- 'TypeTag' must use this helper to help distinguish based on on the runtime
+-- information.
+isBoolTag :: TypeTag t -> Bool
+isBoolTag TypeBool = True
+isBoolTag TypeV2B  = True
+isBoolTag TypeV3B  = True
+isBoolTag TypeV4B  = True
+isBoolTag _        = False
+
+
+-- | Obtain a type-level description of a uniform type context.
+--
+-- See 'unwitnessType' for the inverse operation.
+witnessType :: InputType -> Maybe (Some TypeTag)
+witnessType Bool  = Just $ This TypeBool
+witnessType V2B   = Just $ This TypeV2B
+witnessType V3B   = Just $ This TypeV3B
+witnessType V4B   = Just $ This TypeV4B
+witnessType Word  = Just $ This TypeWord
+witnessType V2U   = Just $ This TypeV2U
+witnessType V3U   = Just $ This TypeV3U
+witnessType V4U   = Just $ This TypeV4U
+witnessType Int   = Just $ This TypeInt
+witnessType V2I   = Just $ This TypeV2I
+witnessType V3I   = Just $ This TypeV3I
+witnessType V4I   = Just $ This TypeV4I
+witnessType Float = Just $ This TypeFloat
+witnessType V2F   = Just $ This TypeV2F
+witnessType V3F   = Just $ This TypeV3F
+witnessType V4F   = Just $ This TypeV4F
+witnessType M22F  = Just $ This TypeM22F
+witnessType M23F  = Just $ This TypeM23F
+witnessType M24F  = Just $ This TypeM24F
+witnessType M32F  = Just $ This TypeM32F
+witnessType M33F  = Just $ This TypeM33F
+witnessType M34F  = Just $ This TypeM34F
+witnessType M42F  = Just $ This TypeM42F
+witnessType M43F  = Just $ This TypeM43F
+witnessType M44F  = Just $ This TypeM44F
+witnessType _     = Nothing
+
+-- | Discard type-level input information.  Inverse of 'witnessType'.
+unwitnessType :: TypeTag c -> InputType
+unwitnessType TypeBool  = Bool
+unwitnessType TypeV2B   = V2B
+unwitnessType TypeV3B   = V3B
+unwitnessType TypeV4B   = V4B
+unwitnessType TypeWord  = Word
+unwitnessType TypeV2U   = V2U
+unwitnessType TypeV3U   = V3U
+unwitnessType TypeV4U   = V4U
+unwitnessType TypeInt   = Int
+unwitnessType TypeV2I   = V2I
+unwitnessType TypeV3I   = V3I
+unwitnessType TypeV4I   = V4I
+unwitnessType TypeFloat = Float
+unwitnessType TypeV2F   = V2F
+unwitnessType TypeV3F   = V3F
+unwitnessType TypeV4F   = V4F
+unwitnessType TypeM22F  = M22F
+unwitnessType TypeM23F  = M23F
+unwitnessType TypeM24F  = M24F
+unwitnessType TypeM32F  = M32F
+unwitnessType TypeM33F  = M33F
+unwitnessType TypeM34F  = M34F
+unwitnessType TypeM42F  = M42F
+unwitnessType TypeM43F  = M43F
+unwitnessType TypeM44F  = M44F
+
+
+-- | A function used to upload a "uniform" primitive value or vector to the
+-- GPU.  If /n/ is 1, then it uploads a primitive value of type /typ/.
+-- Otherwise, it uploads a vector of length /n/.
+--
+-- The arguments to the function are:
+--
+--   * An integer naming the uniform input slot.
+--
+--   * An element count which, if greater than 1, will bulk-upload an array of
+--   values.
+--
+--   * A pointer to the value or values to be uploaded.
+--
+-- Use 'glUniform' to obtain this for a given type context.
+data GLVector (n :: Nat) typ
+    = GLVector (Int32 -> GLsizei -> Ptr typ -> IO ())
+
+
+-- | A function used to upload a "uniform" /r/ × /c/ matrix of /typ/ to the
+-- GPU.  The arguments are:
+--
+--   * An integer naming the uniform input slot.
+--
+--   * An element count which, if greater than 1, will bulk-upload an array.
+--
+--   * A flag that is GL_TRUE if the values at the pointer are arranged in
+--   row-major order.  Set this to GL_FALSE to indicate column-major ordering.
+--   Row-major means that the first /c/ contiguous values at the pointer
+--   constitute the first row of the matrix.
+--
+--   * A pointer to the matrix values.
+--
+-- IMPORTANT: This type flouts the usual graphics convention of width×height,
+-- which is used in the naming of the constructors for 'InputType' and
+-- 'TypeTag', and instead instead follows the opposite, matrix-math convention,
+-- of rows×columns.  Thus, @'TypeM42F'@ is associated with @(GLMatrix 2 4
+-- Float)@.
+--
+-- Use 'glUniform' to obtain this for a given type context.
+data GLMatrix (r :: Nat) (c :: Nat) typ
+    = GLMatrix (Int32 -> GLsizei -> GLboolean -> Ptr typ -> IO ())
+
+-- | Obtain a suitable 'GLVector' or 'GLMatrix' OpenGL API function for a given
+-- uniform type.
+glUniform :: TypeTag a -> a
+glUniform TypeBool  = GLVector glUniform1uiv
+glUniform TypeWord  = GLVector glUniform1uiv
+glUniform TypeInt   = GLVector glUniform1iv
+glUniform TypeFloat = GLVector glUniform1fv
+glUniform TypeV2B   = GLVector glUniform2uiv
+glUniform TypeV2U   = GLVector glUniform2uiv
+glUniform TypeV2I   = GLVector glUniform2iv
+glUniform TypeV2F   = GLVector glUniform2fv
+glUniform TypeV3B   = GLVector glUniform3uiv
+glUniform TypeV3U   = GLVector glUniform3uiv
+glUniform TypeV3I   = GLVector glUniform3iv
+glUniform TypeV3F   = GLVector glUniform3fv
+glUniform TypeV4B   = GLVector glUniform4uiv
+glUniform TypeV4U   = GLVector glUniform4uiv
+glUniform TypeV4I   = GLVector glUniform4iv
+glUniform TypeV4F   = GLVector glUniform4fv
+glUniform TypeM22F  = GLMatrix glUniformMatrix2fv
+glUniform TypeM23F  = GLMatrix glUniformMatrix2x3fv
+glUniform TypeM24F  = GLMatrix glUniformMatrix2x4fv
+glUniform TypeM32F  = GLMatrix glUniformMatrix3x2fv
+glUniform TypeM33F  = GLMatrix glUniformMatrix3fv
+glUniform TypeM34F  = GLMatrix glUniformMatrix3x4fv
+glUniform TypeM42F  = GLMatrix glUniformMatrix4x2fv
+glUniform TypeM43F  = GLMatrix glUniformMatrix4x3fv
+glUniform TypeM44F  = GLMatrix glUniformMatrix4fv
+
+-- | 'GLData' /a/ /c/ is true when /a/ can be used as GL shader "uniform"
+-- input for a 'GLVector' or 'GLMatrix' uniform context /c/.
+--
+-- For simple (non-matrix) types that implement 'Storable', a default
+-- implementation, implemented by 'marshalUniformStorable', is provided, so in
+-- this case, simply declare the instance.  If a 'Storable' column-major matrix
+-- type, 'marshalColumnMajor' can be used.
+class (Typeable c, Typeable a) => GLData a c where
+    -- | Provide a pointer suitable for passing to the OpenGL api.
+    marshalUniform :: GLABI c -- ^ Description of the variable type of the GL uniform.
+                      -> a         -- ^ The value to upload to the GPU.
+                      -> Maybe (MarshalGL c)
+
+    default marshalUniform :: ( c ~ GLVector n typ
+                              , Storable a
+                              ) => GLABI c -> a -> Maybe (MarshalGL c)
+    marshalUniform _ a = Just (marshalUniformStorable a)
+
+-- | A suitable default for 'Storable' uniform non-matrix types.
+marshalUniformStorable :: Storable a => a -> MarshalGL (GLVector n typ)
+marshalUniformStorable a = MarshalGLVector $ \f -> with a (f 1 . castPtr)
+
+-- | A suitable default for 'Storable' uniform column-major matrix types.
+-- Column-major means that columns are stored as contiguous regions of memory
+-- at the pointer.
+marshalColumnMajor :: Storable a => a -> MarshalGL (GLMatrix r c typ)
+marshalColumnMajor a = MarshalGLMatrix $ \f -> with a (f 1 GL_FALSE . castPtr)
+
+
+-- | Run-time information about a "uniform" type context.  A proxy for the
+-- pointer type is provided directly.  You can use 'vectorLength' or
+-- 'matrixDimensions' to extract proxies for size information.
+--
+-- You can obtain this from a 'TypeTag' using 'glABI'.
+data GLABI m where
+    IsGLVector :: KnownNat n => GLPointerType typ -> GLABI (GLVector n typ)
+    IsGLMatrix :: (KnownNat r, KnownNat c) => GLPointerType typ -> GLABI (GLMatrix r c typ)
+
+instance GEq GLABI where
+    geq a@(IsGLVector x) b@(IsGLVector y) = do
+        Refl <- geq x y
+        Refl <- withTypes (vectorLength a) (vectorLength b) <$> eqT
+        return Refl
+    geq a@(IsGLMatrix x) b@(IsGLMatrix y) = do
+        Refl <- geq x y
+        let (ar,ac) = matrixDimensions a
+            (br,bc) = matrixDimensions b
+        Refl <- withTypes (asTypeOf ar RowCount) (asTypeOf br RowCount) <$> eqT
+        Refl <- withTypes (asTypeOf ac ColumnCount) (asTypeOf bc ColumnCount) <$> eqT
+        return Refl
+    geq _ _ = Nothing
+
+instance GCompare GLABI where
+    gcompare IsGLVector{} IsGLMatrix{} = GLT
+    gcompare IsGLMatrix{} IsGLVector{} = GGT
+    gcompare a@(IsGLVector x) b@(IsGLVector y) = case gcompare x y of
+        GLT -> GLT
+        GEQ -> case withTypes (vectorLength a) (vectorLength b) <$> eqT of
+            Just Refl -> GEQ
+            Nothing   -> case compare (natVal $ vectorLength a) (natVal $ vectorLength b) of
+                    LT -> GLT
+                    GT -> GGT
+        GGT -> GGT
+    gcompare a@(IsGLMatrix x) b@(IsGLMatrix y) = case gcompare x y of
+        GLT -> GLT
+        GEQ -> case matrixDimensions a of
+                (ar,ac) -> case matrixDimensions b of
+                  (br,bc) -> case withTypes ar br <$> eqT of
+                    Just Refl -> case withTypes ac bc <$> eqT of
+                        Just Refl -> GEQ
+                        Nothing   -> if natVal ac < natVal bc then GLT else GGT
+                    Nothing -> if natVal ar < natVal br then GLT else GGT
+        GGT -> GGT
+
+
+-- | Run-time encoding of the type of passed pointer to the OpenGL api for a
+-- given uniform.
+data GLPointerType typ where
+    GLPrimUInt  :: GLPointerType Word32
+    GLPrimInt   :: GLPointerType Int32
+    GLPrimFloat :: GLPointerType Float
+
+deriving instance Show (GLPointerType typ)
+
+instance GEq GLPointerType where
+    geq GLPrimUInt  GLPrimUInt  = Just Refl
+    geq GLPrimInt   GLPrimInt   = Just Refl
+    geq GLPrimFloat GLPrimFloat = Just Refl
+
+instance GCompare GLPointerType where
+    gcompare GLPrimUInt  GLPrimUInt  = GEQ
+    gcompare GLPrimUInt  _           = GLT
+    gcompare GLPrimFloat GLPrimFloat = GEQ
+    gcompare GLPrimFloat _           = GGT
+    gcompare GLPrimInt   GLPrimUInt  = GLT
+    gcompare GLPrimInt   GLPrimInt   = GEQ
+    gcompare GLPrimInt   GLPrimFloat = GGT
+
+-- | Convenience proxy for the number of dimensions in a vector.
+data VectorLength (n :: Nat) = VectorLength
+
+-- | Extract the number of dimensions in a vector from a 'GLABI'.
+vectorLength :: GLABI (GLVector n typ) -> VectorLength n
+vectorLength IsGLVector{} = VectorLength
+
+-- | Convenience proxy for the number of rows in a matrix.
+data RowCount (n :: Nat) = RowCount
+
+-- | Convenience proxy for the number of columns in a matrix.
+data ColumnCount (n :: Nat) = ColumnCount
+
+-- | Extract row and column counts from a 'GLABI'.
+matrixDimensions :: GLABI (GLMatrix r c typ) -> (RowCount r, ColumnCount c)
+matrixDimensions IsGLMatrix{} = (RowCount,ColumnCount)
+
+-- | Convenience accessor for the pointer type proxy of a 'GLABI'.
+ptrType :: GLABI (f t) -> GLPointerType t
+ptrType (IsGLVector p) = p
+ptrType (IsGLMatrix p) = p
+
+
+-- | Provides a pointer and element count to a given continuation.
+--
+-- If the pointer refers to matrix data, then a 'GLboolean' is also passed.
+-- This is GL_TRUE when the matrix data is in row-major format (i.e. matrix
+-- rows are contiguous blocks of memory.)
+data MarshalGL c where
+
+    MarshalGLVector :: (forall b. (GLsizei -> Ptr typ -> IO b) -> IO b)
+                        -> MarshalGL (GLVector n typ)
+
+    MarshalGLMatrix :: (forall b. (GLsizei -> GLboolean -> Ptr typ -> IO b) -> IO b)
+                        -> MarshalGL (GLMatrix r c typ)
+
+
+-- | Obtain a type-level description for a given input context.  This is
+-- similar to 'glUniform' except that it is used only as description and does
+-- not provide the actual OpenGL API function.
+glABI :: TypeTag a -> GLABI a
+glABI TypeBool  = IsGLVector GLPrimUInt
+glABI TypeWord  = IsGLVector GLPrimUInt
+glABI TypeInt   = IsGLVector GLPrimInt
+glABI TypeFloat = IsGLVector GLPrimFloat
+glABI TypeV2B   = IsGLVector GLPrimUInt
+glABI TypeV2U   = IsGLVector GLPrimUInt
+glABI TypeV2I   = IsGLVector GLPrimInt
+glABI TypeV2F   = IsGLVector GLPrimFloat
+glABI TypeV3B   = IsGLVector GLPrimUInt
+glABI TypeV3U   = IsGLVector GLPrimUInt
+glABI TypeV3I   = IsGLVector GLPrimInt
+glABI TypeV3F   = IsGLVector GLPrimFloat
+glABI TypeV4B   = IsGLVector GLPrimUInt
+glABI TypeV4U   = IsGLVector GLPrimUInt
+glABI TypeV4I   = IsGLVector GLPrimInt
+glABI TypeV4F   = IsGLVector GLPrimFloat
+glABI TypeM22F  = IsGLMatrix GLPrimFloat
+glABI TypeM23F  = IsGLMatrix GLPrimFloat
+glABI TypeM24F  = IsGLMatrix GLPrimFloat
+glABI TypeM32F  = IsGLMatrix GLPrimFloat
+glABI TypeM33F  = IsGLMatrix GLPrimFloat
+glABI TypeM34F  = IsGLMatrix GLPrimFloat
+glABI TypeM42F  = IsGLMatrix GLPrimFloat
+glABI TypeM43F  = IsGLMatrix GLPrimFloat
+glABI TypeM44F  = IsGLMatrix GLPrimFloat
+
+-- | This is a convenience utility to provide explicit context to
+-- type-equality.  For example, to compare types denoted by proxies /a/ and
+-- /b/, use
+--
+-- > case withTypes a b <$> eqT of
+-- >   Just Refl -> typesAreEqual
+-- >   Nothing   -> typesArenotEqual
+--
+-- This utility is not OpenGL related, but it is used by the GCompare instances
+-- implemented here.
+withTypes :: p (a::k) -> q (b::k) -> f a b -> f a b
+withTypes _ _ x = x
+
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
 {-
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