make more flexible

2 files changed, 43 insertions, 38 deletions

diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index f2216fb..596563a 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -14,6 +14,8 @@ import qualified Data.Set as S
 import qualified Data.Map as Map
 import qualified Data.Vector as V
 import qualified Data.Vector.Algorithms.Intro as I
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as SB
 
 import Graphics.GL.Core33
 
@@ -36,7 +38,7 @@ schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.emp
         Just v  -> v
         Nothing -> error "internal error (schemaFromPipeline)"
 
-mkUniform :: [(String,InputType)] -> IO (Map String InputSetter, Map String GLUniform)
+mkUniform :: [(String,InputType)] -> IO (Map GLUniformName InputSetter, Map String GLUniform)
 mkUniform l = do
     unisAndSetters <- forM l $ \(n,t) -> do
         (uni, setter) <- mkUniformSetter t
@@ -147,7 +149,7 @@ setObjectOrder p obj i = do
     writeIORef (objOrder obj) i
     modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
 
-objectUniformSetter :: Object -> Map String InputSetter
+objectUniformSetter :: Object -> Map GLUniformName InputSetter
 objectUniformSetter = objUniSetter
 
 setScreenSize :: GLStorage -> Word -> Word -> IO ()
@@ -245,41 +247,41 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++
             -- constant generic attribute
             constAttr -> GLSetVertexAttrib i constAttr
 
-nullSetter :: String -> String -> a -> IO ()
+nullSetter :: GLUniformName -> String -> a -> IO ()
 --nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
-nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ n ++ " :: " ++ t
-
-uniformBool  :: String -> Map String InputSetter -> SetterFun Bool
-uniformV2B   :: String -> Map String InputSetter -> SetterFun V2B
-uniformV3B   :: String -> Map String InputSetter -> SetterFun V3B
-uniformV4B   :: String -> Map String InputSetter -> SetterFun V4B
-
-uniformWord  :: String -> Map String InputSetter -> SetterFun Word32
-uniformV2U   :: String -> Map String InputSetter -> SetterFun V2U
-uniformV3U   :: String -> Map String InputSetter -> SetterFun V3U
-uniformV4U   :: String -> Map String InputSetter -> SetterFun V4U
-
-uniformInt   :: String -> Map String InputSetter -> SetterFun Int32
-uniformV2I   :: String -> Map String InputSetter -> SetterFun V2I
-uniformV3I   :: String -> Map String InputSetter -> SetterFun V3I
-uniformV4I   :: String -> Map String InputSetter -> SetterFun V4I
-
-uniformFloat :: String -> Map String InputSetter -> SetterFun Float
-uniformV2F   :: String -> Map String InputSetter -> SetterFun V2F
-uniformV3F   :: String -> Map String InputSetter -> SetterFun V3F
-uniformV4F   :: String -> Map String InputSetter -> SetterFun V4F
-
-uniformM22F   :: String -> Map String InputSetter -> SetterFun M22F
-uniformM23F   :: String -> Map String InputSetter -> SetterFun M23F
-uniformM24F   :: String -> Map String InputSetter -> SetterFun M24F
-uniformM32F   :: String -> Map String InputSetter -> SetterFun M32F
-uniformM33F   :: String -> Map String InputSetter -> SetterFun M33F
-uniformM34F   :: String -> Map String InputSetter -> SetterFun M34F
-uniformM42F   :: String -> Map String InputSetter -> SetterFun M42F
-uniformM43F   :: String -> Map String InputSetter -> SetterFun M43F
-uniformM44F   :: String -> Map String InputSetter -> SetterFun M44F
-
-uniformFTexture2D   :: String -> Map String InputSetter -> SetterFun TextureData
+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
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index 7f83a2a..ebd0582 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -10,12 +10,15 @@ import Data.Vector (Vector)
 import Data.Word
 import Foreign.Ptr
 import Foreign.Storable
+import Data.ByteString
 
 import Graphics.GL.Core33
 
 import Linear
 import IR
 
+type GLUniformName = String -- ByteString
+
 ---------------
 -- Input API --
 ---------------
@@ -101,7 +104,7 @@ data GLStorage
     , slotMap       :: Map String SlotName
     , slotVector    :: Vector (IORef GLSlot)
     , objSeed       :: IORef Int
-    , uniformSetter :: Map String InputSetter
+    , uniformSetter :: Map GLUniformName InputSetter
     , uniformSetup  :: Map String GLUniform
     , screenSize    :: IORef (Word,Word)
     , pipelines     :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines
@@ -113,7 +116,7 @@ data Object -- internal type
     , objPrimitive  :: Primitive
     , objIndices    :: Maybe (IndexStream Buffer)
     , objAttributes :: Map String (Stream Buffer)
-    , objUniSetter  :: Map String InputSetter
+    , objUniSetter  :: Map GLUniformName InputSetter
     , objUniSetup   :: Map String GLUniform
     , objOrder      :: IORef Int
     , objEnabled    :: IORef Bool