1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
{-# 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 qualified Type.Reflection as R
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 Control.Monad.State.Lazy
import MaskableStream
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
let fields = constrFields c
mkb :: (MonadPlus m, Data k) => String -> m k
mkb n = case lookupA n of
Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of
Witness -> maybe mzero return $ cast k
_ -> mzero
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 = go (R.someTypeRep proxy)
where
go :: R.SomeTypeRep -> Maybe (Some TypeTag)
go rep = case rep 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
(p,[x]) -> go x
_ -> 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 pxy 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 -> []
_ -> []
|
