diff options
Diffstat (limited to 'MaskableStream.hs')
-rw-r--r-- | MaskableStream.hs | 55 |
1 files changed, 55 insertions, 0 deletions
diff --git a/MaskableStream.hs b/MaskableStream.hs index 10f4bff..d836f37 100644 --- a/MaskableStream.hs +++ b/MaskableStream.hs | |||
@@ -1,4 +1,7 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
1 | {-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-} | 2 | {-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-} |
3 | {-# LANGUAGE ConstraintKinds #-} | ||
4 | {-# LANGUAGE ScopedTypeVariables #-} | ||
2 | 5 | ||
3 | -- TODO: Formulate this module as a patch against lambdacube-gl. | 6 | -- TODO: Formulate this module as a patch against lambdacube-gl. |
4 | 7 | ||
@@ -38,6 +41,36 @@ import LambdaCube.GL.Input hiding (createObjectCommands) | |||
38 | 41 | ||
39 | import Graphics.GL.Core33 | 42 | import Graphics.GL.Core33 |
40 | 43 | ||
44 | data Witness c = c => Witness | ||
45 | |||
46 | tagTypable :: TypeTag c -> Witness (Typeable c) | ||
47 | tagTypable TypeBool = Witness | ||
48 | tagTypable TypeV2B = Witness | ||
49 | tagTypable TypeV3B = Witness | ||
50 | tagTypable TypeV4B = Witness | ||
51 | tagTypable TypeWord = Witness | ||
52 | tagTypable TypeV2U = Witness | ||
53 | tagTypable TypeV3U = Witness | ||
54 | tagTypable TypeV4U = Witness | ||
55 | tagTypable TypeInt = Witness | ||
56 | tagTypable TypeV2I = Witness | ||
57 | tagTypable TypeV3I = Witness | ||
58 | tagTypable TypeV4I = Witness | ||
59 | tagTypable TypeFloat = Witness | ||
60 | tagTypable TypeV2F = Witness | ||
61 | tagTypable TypeV3F = Witness | ||
62 | tagTypable TypeV4F = Witness | ||
63 | tagTypable TypeM22F = Witness | ||
64 | tagTypable TypeM23F = Witness | ||
65 | tagTypable TypeM24F = Witness | ||
66 | tagTypable TypeM32F = Witness | ||
67 | tagTypable TypeM33F = Witness | ||
68 | tagTypable TypeM34F = Witness | ||
69 | tagTypable TypeM42F = Witness | ||
70 | tagTypable TypeM43F = Witness | ||
71 | tagTypable TypeM44F = Witness | ||
72 | |||
73 | |||
41 | 74 | ||
42 | -- based on addMeshToObjectArray | 75 | -- based on addMeshToObjectArray |
43 | addToObjectArray :: GLStorage | 76 | addToObjectArray :: GLStorage |
@@ -233,7 +266,29 @@ incrementalUpdateBuffer b byteoffset bytecount ptr = do | |||
233 | glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr | 266 | glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr |
234 | glBindBuffer GL_ARRAY_BUFFER 0 | 267 | glBindBuffer GL_ARRAY_BUFFER 0 |
235 | 268 | ||
269 | deriving instance Data InputType | ||
270 | deriving instance Data ArrayType | ||
271 | deriving instance Data ArrayDesc | ||
272 | deriving instance Data Buffer | ||
236 | instance Typeable c => Data (AttributeKey c) where | 273 | instance Typeable c => Data (AttributeKey c) where |
274 | gfoldl f z (AttributeKey tt b offset) = z mk | ||
275 | `f` unwitnessType tt | ||
276 | `f` b | ||
277 | `f` fromIntegral offset | ||
278 | where | ||
279 | mk :: Typeable c => InputType -> Buffer -> Int64 -> AttributeKey c | ||
280 | mk t bo i = fix $ \ret -> case witnessType t of | ||
281 | Just (This tt) -> case tagTypable tt of | ||
282 | Witness -> case withTypes tt ret <$> eqT of | ||
283 | Just Refl -> AttributeKey tt bo (fromIntegral i) | ||
284 | toConstr _ = error "AttributeKey.toConstr" | ||
285 | gunfold _ _ = error "AttributeKey.gunfold" | ||
286 | #if MIN_VERSION_base(4,2,0) | ||
287 | dataTypeOf _ = mkNoRepType "MaskableStream.AttributeKey" | ||
288 | #else | ||
289 | dataTypeOf _ = mkNorepType "MaskableStream.AttributeKey" | ||
290 | #endif | ||
291 | |||
237 | 292 | ||
238 | data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff | 293 | data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff |
239 | 294 | ||