Fleshed-out Data instance for AttributeKey.

2 files changed, 55 insertions, 29 deletions

diff --git a/AttributeData.hs b/AttributeData.hs
index 59b9e6d..d962a06 100644
--- a/AttributeData.hs
+++ b/AttributeData.hs
@@ -41,35 +41,6 @@ import Control.Monad.State.Lazy
 
 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
-
 
 lookupAttrKeys :: forall attrkeys. Data attrkeys => (String -> Maybe (Some AttributeKey)) -> Maybe attrkeys
 lookupAttrKeys lookupA = do
diff --git a/MaskableStream.hs b/MaskableStream.hs
index 10f4bff..d836f37 100644
--- a/MaskableStream.hs
+++ b/MaskableStream.hs
@@ -1,4 +1,7 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- TODO: Formulate this module as a patch against lambdacube-gl.
 
@@ -38,6 +41,36 @@ import LambdaCube.GL.Input hiding (createObjectCommands)
 
 import Graphics.GL.Core33
 
+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
+
+
 
 -- based on addMeshToObjectArray
 addToObjectArray :: GLStorage
@@ -233,7 +266,29 @@ incrementalUpdateBuffer b byteoffset bytecount ptr = do
     glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr
     glBindBuffer GL_ARRAY_BUFFER 0
 
+deriving instance Data InputType
+deriving instance Data ArrayType
+deriving instance Data ArrayDesc
+deriving instance Data Buffer
 instance Typeable c => Data (AttributeKey c) where
+  gfoldl f z (AttributeKey tt b offset) = z mk
+                                            `f` unwitnessType tt
+                                            `f` b
+                                            `f` fromIntegral offset
+    where
+        mk :: Typeable c => InputType -> Buffer -> Int64 -> AttributeKey c
+        mk t bo i = fix $ \ret -> case witnessType t of
+            Just (This tt) -> case tagTypable tt of
+                Witness -> case withTypes tt ret <$> eqT of
+                    Just Refl -> AttributeKey tt bo (fromIntegral i)
+  toConstr _     = error "AttributeKey.toConstr"
+  gunfold _ _    = error "AttributeKey.gunfold"
+#if MIN_VERSION_base(4,2,0)
+  dataTypeOf _   = mkNoRepType "MaskableStream.AttributeKey"
+#else
+  dataTypeOf _   = mkNorepType "MaskableStream.AttributeKey"
+#endif
+
 
 data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff