Representation-agnostic matrix/vector pipeline inputs.

1 files changed, 196 insertions, 192 deletions

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