Experiment: use Data.Data to generate AttributeKeys.

2 files changed, 106 insertions, 1 deletions

diff --git a/AttributeData.hs b/AttributeData.hs
new file mode 100644
index 0000000..2b2bc96
--- /dev/null
+++ b/AttributeData.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module AttributeData where
+
+import Control.Monad
+import Data.Data
+import Data.Foldable
+import Data.Function
+import Data.Int
+import Data.IORef
+import Data.Maybe
+import Data.Some
+import Data.Word
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector as V
+         ;import Data.Vector as V ((!),(//))
+import Foreign.C.Types (CPtrdiff)
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+
+import LambdaCube.GL      as LC
+import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
+import LambdaCube.GL.Mesh as LC
+import LambdaCube.GL.Type
+import LambdaCube.IR      as LC
+import LambdaCube.GL.Util
+import LambdaCube.GL.Input.Type
+import LambdaCube.GL.Input hiding (createObjectCommands)
+
+
+import MaskableStream
+
+data Witness c = c => Witness
+
+tagTypable :: TypeTag c -> Witness (Typeable c)
+tagTypable TypeBool  = Witness
+tagTypable TypeV2B   = Witness
+tagTypable TypeV3B   = Witness
+tagTypable TypeV4B   = Witness
+tagTypable TypeWord  = Witness
+tagTypable TypeV2U   = Witness
+tagTypable TypeV3U   = Witness
+tagTypable TypeV4U   = Witness
+tagTypable TypeInt   = Witness
+tagTypable TypeV2I   = Witness
+tagTypable TypeV3I   = Witness
+tagTypable TypeV4I   = Witness
+tagTypable TypeFloat = Witness
+tagTypable TypeV2F   = Witness
+tagTypable TypeV3F   = Witness
+tagTypable TypeV4F   = Witness
+tagTypable TypeM22F  = Witness
+tagTypable TypeM23F  = Witness
+tagTypable TypeM24F  = Witness
+tagTypable TypeM32F  = Witness
+tagTypable TypeM33F  = Witness
+tagTypable TypeM34F  = Witness
+tagTypable TypeM42F  = Witness
+tagTypable TypeM43F  = Witness
+tagTypable TypeM44F  = Witness
+
+
+foo :: forall attrkeys. Data attrkeys => (String -> Maybe (Some AttributeKey)) -> Maybe attrkeys
+foo lookupA = do
+    let dt = dataTypeOf (error "dataTypeOf attrkeys" :: attrkeys)
+    case dataTypeRep dt of
+        AlgRep (c:_) -> do
+            let fields = constrFields c
+                mkb :: Data k => String -> k
+                mkb n = fix $ \v ->
+                    fromMaybe (error $ "mkb " ++ n) $ case lookupA n of
+                        Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of
+                            Witness -> cast k
+                        _ -> Nothing
+                z :: x -> (,) [String] x
+                z r = (fields, r)
+                k :: Data b => (,) [String] (b -> r) -> (,) [String] r
+                k (n:ns,btor) = (ns,btor (mkb n))
+                (_,ks) = gunfold k z c :: (,) [String] attrkeys
+            Just ks
+        _ -> Nothing
+
diff --git a/MaskableStream.hs b/MaskableStream.hs
index 5274d28..10f4bff 100644
--- a/MaskableStream.hs
+++ b/MaskableStream.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs #-}
+{-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-}
 
 -- TODO: Formulate this module as a patch against lambdacube-gl.
 
@@ -7,6 +7,7 @@ module MaskableStream where
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Writer
+import Data.Data
 import Data.Foldable
 import Data.Function
 import Data.Int
@@ -232,6 +233,8 @@ incrementalUpdateBuffer b byteoffset bytecount ptr = do
     glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr
     glBindBuffer GL_ARRAY_BUFFER 0
 
+instance Typeable c => Data (AttributeKey c) where
+
 data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff
 
 attributeKey :: TypeTagable c => GPUData -> String -> Maybe (AttributeKey c)
@@ -249,6 +252,17 @@ attributeKey dta name = do
             Just $ AttributeKey typ b (fromIntegral off)
         _ -> Nothing
 
+lookupAttributeKey :: GPUData -> String -> Maybe (Some AttributeKey)
+lookupAttributeKey dta name = do
+    stream <- Map.lookup name (dStreams dta)
+    case stream of
+        Stream t b i _ _ -> do
+            let a = bufArrays b ! i
+                off = arrOffset a
+            This tt <- witnessType (fromStreamType t)
+            Just $ This (AttributeKey tt b (fromIntegral off))
+        _ -> Nothing
+
 (@<-) :: GLData a c => AttributeKey c -> a -> Writer [DSum AttributeKey GLUniformValue] ()
 k @<- v = tell [k :=> GLUniformValue v]