Vertex attributes: Use relfection to obtain Parameter list.

1 files changed, 88 insertions, 11 deletions

diff --git a/AttributeData.hs b/AttributeData.hs
index 86cb1e4..8e149af 100644
--- a/AttributeData.hs
+++ b/AttributeData.hs
@@ -26,6 +26,7 @@ import Foreign.C.Types (CPtrdiff)
 import Foreign.Marshal
 import Foreign.Ptr
 import Foreign.Storable
+import qualified Type.Reflection as R
 
 import LambdaCube.GL      as LC
 import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
@@ -70,8 +71,8 @@ tagTypable TypeM43F  = Witness
 tagTypable TypeM44F  = Witness
 
 
-foo :: forall attrkeys. Data attrkeys => (String -> Maybe (Some AttributeKey)) -> Maybe attrkeys
-foo lookupA = do
+lookupAttrKeys :: forall attrkeys. Data attrkeys => (String -> Maybe (Some AttributeKey)) -> Maybe attrkeys
+lookupAttrKeys lookupA = do
     let dt = dataTypeOf (error "dataTypeOf attrkeys" :: attrkeys)
     case dataTypeRep dt of
         AlgRep (c:_) -> do
@@ -81,14 +82,90 @@ foo lookupA = do
                             Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of
                                 Witness -> maybe mzero return $ cast k
                             _ -> mzero
-                z :: x -> StateT [String] Maybe x
-                z r = put fields >> return r
-                k :: Data b => StateT [String] Maybe (b -> r) -> StateT [String] Maybe r
-                k c = do btor <- c
-                         n:ns <- get
-                         put ns
-                         a <- mkb n
-                         return (btor a)
-            evalStateT (gunfold k z c) [] -- :: (,) [String] attrkeys
+            evalStateT (do { n:ns <- get ; put ns ; mkb n } `fromConstrM` c)
+                       fields
         _ -> Nothing
 
+
+reflectDim :: Num a => R.SomeTypeRep -> Maybe a
+reflectDim r = case () of
+    () | r==R.someTypeRep (Proxy :: Proxy 1) -> Just 1
+       | r==R.someTypeRep (Proxy :: Proxy 2) -> Just 2
+       | r==R.someTypeRep (Proxy :: Proxy 3) -> Just 3
+       | r==R.someTypeRep (Proxy :: Proxy 4) -> Just 4
+       | otherwise -> Nothing
+
+reflectPrim :: R.SomeTypeRep -> Maybe (Some GLPointerType)
+reflectPrim r = case () of
+    () | r==R.someTypeRep (Proxy :: Proxy Float)  -> Just (This GLPrimFloat)
+       | r==R.someTypeRep (Proxy :: Proxy Int32)  -> Just (This GLPrimInt)
+       | r==R.someTypeRep (Proxy :: Proxy Word32) -> Just (This GLPrimUInt)
+       | otherwise -> Nothing
+
+
+reflectVectorType :: Typeable a => proxy a -> Maybe (Some TypeTag)
+reflectVectorType proxy = case R.someTypeRep proxy of
+    R.SomeTypeRep r -> case R.splitApps r of
+        (v,[c,a])   -> do
+            cols <- reflectDim c
+            This p <- reflectPrim a
+            Just $ case p of
+                GLPrimUInt  -> case cols of
+                    1 -> This TypeWord
+                    2 -> This TypeV2U
+                    3 -> This TypeV3U
+                    4 -> This TypeV4U
+                GLPrimInt   -> case cols of
+                    1 -> This TypeInt
+                    2 -> This TypeV2I
+                    3 -> This TypeV3I
+                    4 -> This TypeV4I
+                GLPrimFloat -> case cols of
+                    1 -> This TypeFloat
+                    2 -> This TypeV2F
+                    3 -> This TypeV3F
+                    4 -> This TypeV4F
+        (m,[r,c,a]) -> do
+            rows <- reflectDim r
+            cols <- reflectDim c
+            This p <- reflectPrim a
+            case p of
+                GLPrimFloat -> case cols of
+                    2 -> case rows of
+                        2 -> Just $ This TypeM22F
+                        3 -> Just $ This TypeM23F
+                        4 -> Just $ This TypeM24F
+                        _ -> Nothing
+                    3 -> case rows of
+                        2 -> Just $ This TypeM32F
+                        3 -> Just $ This TypeM33F
+                        4 -> Just $ This TypeM34F
+                        _ -> Nothing
+                    4 -> case rows of
+                        2 -> Just $ This TypeM42F
+                        3 -> Just $ This TypeM43F
+                        4 -> Just $ This TypeM44F
+                        _ -> Nothing
+                _ -> Nothing
+        _           -> Nothing
+
+fieldParameters :: forall attrkeys proxy. Data attrkeys => proxy attrkeys -> (String -> String) -> [Parameter]
+fieldParameters proxy toAttrName = do
+    let dt = dataTypeOf (error "dataTypeOf attrkeys" :: attrkeys)
+    case dataTypeRep dt of
+        AlgRep (c:_) -> do
+            let fields = constrFields c
+                mkb :: (MonadPlus m, Data k) => p k -> String -> m InputType
+                mkb pxy n = case reflectVectorType proxy of
+                    Just (This tt) -> return $ unwitnessType tt
+                    _              -> mzero
+                go :: Data c => StateT ([String],[Parameter]) Maybe c
+                go = do (n:ns,ps) <- get
+                        fix $ \pxy -> do
+                            t <- mkb pxy n
+                            put (ns,Parameter (toAttrName n) t:ps)
+                            return undefined
+            case runStateT (go `fromConstrM` c) (fields,[]) of
+                Just (x,(_,ps)) -> ps where _ = x :: attrkeys
+                Nothing         -> []
+        _ -> []