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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# 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
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
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 -> []
_ -> []
|
