Experiment: use Data.Data to generate AttributeKeys.

1 files changed, 91 insertions, 0 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
+