summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2015-09-07 18:37:15 +0200
committerCsaba Hruska <csaba.hruska@gmail.com>2015-09-07 18:37:15 +0200
commitab758fd36fae40f3cc998065b8bf9c4ce5e8169b (patch)
treebaebb3584770c6abb64c821daa62e1769816aaaa
add data definition edsl
Diffstat
-rw-r--r--Definitions.hs402
-rw-r--r--Generate.hs56
-rw-r--r--Language.hs236
-rw-r--r--templates/data.hs.ede27
-rw-r--r--templates/data.purs.ede16
-rw-r--r--templates/decode.hs.ede26
-rw-r--r--templates/decode.purs.ede19
-rw-r--r--templates/encode.hs.ede26
-rw-r--r--templates/encode.purs.ede15
9 files changed, 823 insertions, 0 deletions
diff --git a/Definitions.hs b/Definitions.hs
new file mode 100644
index 0000000..d117975
--- /dev/null
+++ b/Definitions.hs
@@ -0,0 +1,402 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Definitions where
3
4import Control.Monad.Writer
5import Language
6
7ir = execWriter $ do
8 -- type aliases
9 "StreamName" #= Int
10 "ProgramName" #= Int
11 "TextureName" #= Int
12 "SamplerName" #= Int
13 "UniformName" #= String
14 "SlotName" #= Int
15 "FrameBufferComponent" #= Int
16 "TextureUnit" #= Int
17 "RenderTargetName" #= Int
18 "TextureUnitMapping" #= Map "UniformName" "TextureUnit"
19
20 -- definitions
21 data_ "ArrayValue" $ do
22 const_ "VBoolArray" [Array Bool]
23 const_ "VIntArray" [Array Int32]
24 const_ "VWordArray" [Array Word32]
25 const_ "VFloatArray" [Array Float]
26
27 data_ "Value" $ do
28 const_ "VBool" [Bool]
29 const_ "VV2B" [v2b]
30 const_ "VV3B" [v3b]
31 const_ "VV4B" [v4b]
32 const_ "VWord" [Word32]
33 const_ "VV2U" [v2u]
34 const_ "VV3U" [v3u]
35 const_ "VV4U" [v4u]
36 const_ "VInt" [Int32]
37 const_ "VV2I" [v2i]
38 const_ "VV3I" [v3i]
39 const_ "VV4I" [v4i]
40 const_ "VFloat" [Float]
41 const_ "VV2F" [v2f]
42 const_ "VV3F" [v3f]
43 const_ "VV4F" [v4f]
44 const_ "VM22F" [m22]
45 const_ "VM23F" [m23]
46 const_ "VM24F" [m24]
47 const_ "VM32F" [m32]
48 const_ "VM33F" [m33]
49 const_ "VM34F" [m34]
50 const_ "VM42F" [m42]
51 const_ "VM43F" [m43]
52 const_ "VM44F" [m44]
53
54 data_ "InputType" $ do
55 enum_ "Bool"
56 enum_ "V2B"
57 enum_ "V3B"
58 enum_ "V4B"
59 enum_ "Word"
60 enum_ "V2U"
61 enum_ "V3U"
62 enum_ "V4U"
63 enum_ "Int"
64 enum_ "V2I"
65 enum_ "V3I"
66 enum_ "V4I"
67 enum_ "Float"
68 enum_ "V2F"
69 enum_ "V3F"
70 enum_ "V4F"
71 enum_ "M22F"
72 enum_ "M23F"
73 enum_ "M24F"
74 enum_ "M32F"
75 enum_ "M33F"
76 enum_ "M34F"
77 enum_ "M42F"
78 enum_ "M43F"
79 enum_ "M44F"
80 -- shadow textures
81 enum_ "STexture1D"
82 enum_ "STexture2D"
83 enum_ "STextureCube"
84 enum_ "STexture1DArray"
85 enum_ "STexture2DArray"
86 enum_ "STexture2DRect"
87 -- float textures
88 enum_ "FTexture1D"
89 enum_ "FTexture2D"
90 enum_ "FTexture3D"
91 enum_ "FTextureCube"
92 enum_ "FTexture1DArray"
93 enum_ "FTexture2DArray"
94 enum_ "FTexture2DMS"
95 enum_ "FTexture2DMSArray"
96 enum_ "FTextureBuffer"
97 enum_ "FTexture2DRect"
98 -- int textures
99 enum_ "ITexture1D"
100 enum_ "ITexture2D"
101 enum_ "ITexture3D"
102 enum_ "ITextureCube"
103 enum_ "ITexture1DArray"
104 enum_ "ITexture2DArray"
105 enum_ "ITexture2DMS"
106 enum_ "ITexture2DMSArray"
107 enum_ "ITextureBuffer"
108 enum_ "ITexture2DRect"
109 -- uint textures
110 enum_ "UTexture1D"
111 enum_ "UTexture2D"
112 enum_ "UTexture3D"
113 enum_ "UTextureCube"
114 enum_ "UTexture1DArray"
115 enum_ "UTexture2DArray"
116 enum_ "UTexture2DMS"
117 enum_ "UTexture2DMSArray"
118 enum_ "UTextureBuffer"
119 enum_ "UTexture2DRect"
120
121 data_ "PointSpriteCoordOrigin" $ do
122 enum_ "LowerLeft"
123 enum_ "UpperLeft"
124
125 data_ "PointSize" $ do
126 const_ "PointSize" [Float]
127 enum_ "ProgramPointSize"
128
129 data_ "PolygonOffset" $ do
130 enum_ "NoOffset"
131 const_ "Offset" [Float,Float]
132
133 data_ "FrontFace" $ do
134 enum_ "CCW"
135 enum_ "CW"
136
137 data_ "PolygonMode" $ do
138 const_ "PolygonPoint" ["PointSize"]
139 const_ "PolygonLine" [Float]
140 enum_ "PolygonFill"
141
142 data_ "ProvokingVertex" $ do
143 enum_ "FirstVertex"
144 enum_ "LastVertex"
145
146 data_ "CullMode" $ do
147 enum_ "CullNone"
148 const_ "CullFront" ["FrontFace"]
149 const_ "CullBack" ["FrontFace"]
150
151 data_ "ComparisonFunction" $ do
152 enum_ "Never"
153 enum_ "Less"
154 enum_ "Equal"
155 enum_ "Lequal"
156 enum_ "Greater"
157 enum_ "Notequal"
158 enum_ "Gequal"
159 enum_ "Always"
160
161 "DepthFunction" #= "ComparisonFunction"
162
163 data_ "StencilOperation" $ do
164 enum_ "OpZero"
165 enum_ "OpKeep"
166 enum_ "OpReplace"
167 enum_ "OpIncr"
168 enum_ "OpIncrWrap"
169 enum_ "OpDecr"
170 enum_ "OpDecrWrap"
171 enum_ "OpInvert"
172
173 data_ "BlendEquation" $ do
174 enum_ "FuncAdd"
175 enum_ "FuncSubtract"
176 enum_ "FuncReverseSubtract"
177 enum_ "Min"
178 enum_ "Max"
179
180 data_ "BlendingFactor" $ do
181 enum_ "Zero"
182 enum_ "One"
183 enum_ "SrcColor"
184 enum_ "OneMinusSrcColor"
185 enum_ "DstColor"
186 enum_ "OneMinusDstColor"
187 enum_ "SrcAlpha"
188 enum_ "OneMinusSrcAlpha"
189 enum_ "DstAlpha"
190 enum_ "OneMinusDstAlpha"
191 enum_ "ConstantColor"
192 enum_ "OneMinusConstantColor"
193 enum_ "ConstantAlpha"
194 enum_ "OneMinusConstantAlpha"
195 enum_ "SrcAlphaSaturate"
196
197 data_ "LogicOperation" $ do
198 enum_ "Clear"
199 enum_ "And"
200 enum_ "AndReverse"
201 enum_ "Copy"
202 enum_ "AndInverted"
203 enum_ "Noop"
204 enum_ "Xor"
205 enum_ "Or"
206 enum_ "Nor"
207 enum_ "Equiv"
208 enum_ "Invert"
209 enum_ "OrReverse"
210 enum_ "CopyInverted"
211 enum_ "OrInverted"
212 enum_ "Nand"
213 enum_ "Set"
214
215 data_ "StencilOps" $ do
216 constR_ "StencilOps"
217 [ "frontStencilOp" #:: "StencilOperation" -- ^ Used for front faced triangles and other primitives.
218 , "backStencilOp" #:: "StencilOperation" -- ^ Used for back faced triangles.
219 ]
220
221 data_ "StencilTests" $ do
222 const_ "StencilTests" ["StencilTest", "StencilTest"]
223
224 data_ "StencilTest" $ do
225 constR_ "StencilTest"
226 [ "stencilComparision" #:: "ComparisonFunction" -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
227 , "stencilReference" #:: Int32 -- ^ The value to compare with the stencil buffer's value.
228 , "stencilMask" #:: Word32 -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
229 ]
230
231 data_ "FetchPrimitive" $ do
232 enum_ "Points"
233 enum_ "Lines"
234 enum_ "Triangles"
235 enum_ "LinesAdjacency"
236 enum_ "TrianglesAdjacency"
237
238 data_ "OutputPrimitive" $ do
239 enum_ "TrianglesOutput"
240 enum_ "LinesOutput"
241 enum_ "PointsOutput"
242
243 data_ "ColorArity" $ do
244 enum_ "Red"
245 enum_ "RG"
246 enum_ "RGB"
247 enum_ "RGBA"
248
249 data_ "Blending" $ do
250 enum_ "NoBlending"
251 const_ "BlendLogicOp" ["LogicOperation"]
252 const_ "Blend" [ Tuple ["BlendEquation", "BlendEquation"]
253 , Tuple [Tuple ["BlendingFactor","BlendingFactor"],Tuple ["BlendingFactor","BlendingFactor"]]
254 , v4f
255 ]
256
257 data_ "RasterContext" $ do
258 const_ "PointCtx" ["PointSize", Float, "PointSpriteCoordOrigin"]
259 const_ "LineCtx" [Float, "ProvokingVertex"]
260 const_ "TriangleCtx" ["CullMode", "PolygonMode", "PolygonOffset", "ProvokingVertex"]
261
262 data_ "FragmentOperation" $ do
263 const_ "DepthOp" ["DepthFunction", Bool]
264 const_ "StencilOp" ["StencilTests", "StencilOps", "StencilOps"]
265 const_ "ColorOp" ["Blending", "Value"]
266
267 data_ "AccumulationContext" $ do
268 constR_ "AccumulationContext"
269 [ "accViewportName" #:: Maybe String
270 , "accOperations" #:: List "FragmentOperation"
271 ]
272
273 data_ "TextureDataType" $ do
274 const_ "FloatT" ["ColorArity"]
275 const_ "IntT" ["ColorArity"]
276 const_ "WordT" ["ColorArity"]
277 enum_ "ShadowT"
278
279 data_ "TextureType" $ do
280 const_ "Texture1D" ["TextureDataType", Int]
281 const_ "Texture2D" ["TextureDataType", Int]
282 const_ "Texture3D" ["TextureDataType"]
283 const_ "TextureCube" ["TextureDataType"]
284 const_ "TextureRect" ["TextureDataType"]
285 const_ "Texture2DMS" ["TextureDataType", Int, Int, Bool]
286 const_ "TextureBuffer" ["TextureDataType"]
287
288 data_ "MipMap" $ do
289 const_ "Mip" [Int,Int] -- Base level, Max level
290 enum_ "NoMip"
291 const_ "AutoMip" [Int,Int] -- Base level, Max level
292
293 data_ "Filter" $ do
294 enum_ "Nearest"
295 enum_ "Linear"
296 enum_ "NearestMipmapNearest"
297 enum_ "NearestMipmapLinear"
298 enum_ "LinearMipmapNearest"
299 enum_ "LinearMipmapLinear"
300
301 data_ "EdgeMode" $ do
302 enum_ "Repeat"
303 enum_ "MirroredRepeat"
304 enum_ "ClampToEdge"
305 enum_ "ClampToBorder"
306
307 data_ "ImageRef" $ do
308 const_ "TextureImage" ["TextureName", Int, Maybe Int] -- Texture name, mip index, array index
309 const_ "Framebuffer" ["ImageSemantic"]
310
311 data_ "ImageSemantic" $ do
312 enum_ "Depth"
313 enum_ "Stencil"
314 enum_ "Color"
315
316 data_ "Command" $ do
317 const_ "SetRasterContext" ["RasterContext"]
318 const_ "SetAccumulationContext" ["AccumulationContext"]
319 const_ "SetRenderTarget" ["RenderTargetName"]
320 const_ "SetProgram" ["ProgramName"] --TextureUnitMapping -- adding texture unit map to set program command seems to be better solution than the current one
321 const_ "SetSamplerUniform" ["UniformName", "TextureUnit"] -- hint: currently the texture unit mapping is encoded with this command
322 const_ "SetTexture" ["TextureUnit", "TextureName"] -- binds texture to the specified texture unit
323 const_ "SetSampler" ["TextureUnit", Maybe "SamplerName"] -- binds sampler to the specified texture unit
324 const_ "RenderSlot" ["SlotName"]
325 const_ "RenderStream" ["StreamName"]
326 const_ "ClearRenderTarget" [Array (Tuple ["ImageSemantic","Value"])]
327 const_ "GenerateMipMap" ["TextureUnit"]
328 const_ "SaveImage" ["FrameBufferComponent", "ImageRef"] -- from framebuffer component to texture (image)
329 const_ "LoadImage" ["ImageRef", "FrameBufferComponent"] -- from texture (image) to framebuffer component
330
331 data_ "TextureDescriptor" $ do -- texture size, type, array, mipmap
332 constR_ "TextureDescriptor"
333 [ "textureType" #:: "TextureType"
334 , "textureSize" #:: "Value"
335 , "textureSemantic" #:: "ImageSemantic"
336 , "textureSampler" #:: "SamplerDescriptor"
337 , "textureBaseLevel" #:: Int
338 , "textureMaxLevel" #:: Int
339 ]
340
341 data_ "SamplerDescriptor" $ do
342 constR_ "SamplerDescriptor"
343 [ "samplerWrapS" #:: "EdgeMode"
344 , "samplerWrapT" #:: Maybe "EdgeMode"
345 , "samplerWrapR" #:: Maybe "EdgeMode"
346 , "samplerMinFilter" #:: "Filter"
347 , "samplerMagFilter" #:: "Filter"
348 , "samplerBorderColor" #:: "Value"
349 , "samplerMinLod" #:: Maybe Float
350 , "samplerMaxLod" #:: Maybe Float
351 , "samplerLodBias" #:: Float
352 , "samplerCompareFunc" #:: Maybe "ComparisonFunction"
353 ]
354
355 data_ "Program" $ do -- AST, input
356 constR_ "Program"
357 [ "programUniforms" #:: Map "UniformName" "InputType" -- uniform input (value based uniforms only / no textures)
358 , "programStreams" #:: Map "UniformName" (Tuple [String,"InputType"]) -- vertex shader input attribute name -> (slot attribute name, attribute type)
359 , "programInTextures" #:: Map "UniformName" "InputType" -- all textures (uniform textures and render textures) referenced by the program
360 , "programOutput" #:: Array (Tuple [String,"InputType"])
361 , "vertexShader" #:: String
362 , "geometryShader" #:: Maybe String
363 , "fragmentShader" #:: String
364 ]
365
366 data_ "Slot" $ do -- input, primitive type
367 constR_ "Slot"
368 [ "slotName" #:: String
369 , "slotStreams" #:: Map String "InputType"
370 , "slotUniforms" #:: Map "UniformName" "InputType"
371 , "slotPrimitive" #:: "FetchPrimitive"
372 , "slotPrograms" #:: Array "ProgramName"
373 ]
374
375 data_ "StreamData" $ do
376 constR_ "StreamData"
377 [ "streamData" #:: Map String "ArrayValue"
378 , "streamType" #:: Map String "InputType"
379 , "streamPrimitive" #:: "FetchPrimitive"
380 , "streamPrograms" #:: Array "ProgramName"
381 ]
382
383 data_ "RenderTarget" $ do
384 constR_ "RenderTarget"
385 [ "renderTargets" #:: Array (Tuple ["ImageSemantic",Maybe "ImageRef"]) -- render texture or default framebuffer (semantic, render texture for the program output)
386 ]
387
388 data_ "Backend" $ do
389 enum_ "WebGL1"
390 enum_ "OpenGL33"
391
392 data_ "Pipeline" $ do
393 constR_ "Pipeline"
394 [ "backend" #:: "Backend"
395 , "textures" #:: Array "TextureDescriptor"
396 , "samplers" #:: Array "SamplerDescriptor"
397 , "targets" #:: Array "RenderTarget"
398 , "programs" #:: Array "Program"
399 , "slots" #:: Array "Slot"
400 , "streams" #:: Array "StreamData"
401 , "commands" #:: Array "Command"
402 ]
diff --git a/Generate.hs b/Generate.hs
new file mode 100644
index 0000000..d4946fb
--- /dev/null
+++ b/Generate.hs
@@ -0,0 +1,56 @@
1{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
2import qualified Data.Text.Lazy as LText
3import Text.EDE
4import Text.EDE.Filters
5
6import Data.HashMap.Strict (HashMap)
7import qualified Data.HashMap.Strict as Map
8import Data.Text (Text)
9
10import Data.Time.Clock
11
12import Definitions
13import Language
14
15instance Unquote [Field]
16instance Unquote [Char]
17instance Quote [Char]
18instance Unquote DataDef
19instance Unquote Type
20
21mylib :: HashMap Text Term
22mylib = Map.fromList
23 -- boolean
24 [ "hasFieldNames" @: hasFieldNames
25 , "parens" @: parens
26 , "constType" @: constType
27 , "hsType" @: hsType
28 , "psType" @: psType
29 ]
30
31
32main :: IO ()
33main = do
34 irHs <- eitherParseFile "templates/data.hs.ede"
35 irEncodeHs <- eitherParseFile "templates/encode.hs.ede"
36 irDecodeHs <- eitherParseFile "templates/decode.hs.ede"
37 irPs <- eitherParseFile "templates/data.purs.ede"
38 irEncodePs <- eitherParseFile "templates/encode.purs.ede"
39 irDecodePs <- eitherParseFile "templates/decode.purs.ede"
40 let generate name def = do
41 dt <- getCurrentTime
42 let env = fromPairs
43 [ "dataAndType" .= def
44 , "definitions" .= [a | a@DataDef{} <- def ]
45 , "moduleName" .= name
46 , "dateTime" .= dt
47 ]
48 -- Haskell
49 either error (\x -> writeFile ("out/" ++ name ++ ".hs") $ LText.unpack x) $ irHs >>= (\t -> eitherRenderWith mylib t env)
50 either error (\x -> writeFile ("out/" ++ name ++ "Encode.hs") $ LText.unpack x) $ irEncodeHs >>= (\t -> eitherRenderWith mylib t env)
51 either error (\x -> writeFile ("out/" ++ name ++ "Decode.hs") $ LText.unpack x) $ irDecodeHs >>= (\t -> eitherRenderWith mylib t env)
52 -- Purescript
53 either error (\x -> writeFile ("out/" ++ name ++ ".purs") $ LText.unpack x) $ irPs >>= (\t -> eitherRenderWith mylib t env)
54 either error (\x -> writeFile ("out/" ++ name ++ "Encode.purs") $ LText.unpack x) $ irEncodePs >>= (\t -> eitherRenderWith mylib t env)
55 either error (\x -> writeFile ("out/" ++ name ++ "Decode.purs") $ LText.unpack x) $ irDecodePs >>= (\t -> eitherRenderWith mylib t env)
56 generate "IR" ir
diff --git a/Language.hs b/Language.hs
new file mode 100644
index 0000000..ae38916
--- /dev/null
+++ b/Language.hs
@@ -0,0 +1,236 @@
1{-# LANGUAGE RankNTypes, OverloadedStrings, DeriveGeneric, LambdaCase #-}
2module Language where
3
4import GHC.Generics
5import Data.Aeson (ToJSON(..),FromJSON(..))
6import Control.Monad.Writer
7import Data.String
8import Data.List
9
10instance IsString Type where
11 fromString a = Data a
12
13data DataDef
14 = DataDef
15 { dataName :: String
16 , constructors :: [ConstructorDef]
17 }
18 | TypeAlias
19 { aliasName :: String
20 , aliasType :: Type
21 }
22 deriving (Show,Generic)
23
24data ConstructorDef
25 = ConstructorDef
26 { name :: String
27 , fields :: [Field]
28 }
29 deriving (Show,Generic)
30
31data Field
32 = Field
33 { fieldName :: String
34 , fieldType :: Type
35 }
36 deriving (Show,Generic)
37
38data Type
39 = Int
40 | Int32
41 | Word
42 | Word32
43 | Float
44 | Bool
45 | String
46 | V2 Type
47 | V3 Type
48 | V4 Type
49 -- higher order types
50 | Array Type
51 | List Type
52 | Tuple [Type]
53 | Maybe Type
54 | Map Type Type
55 -- user defined
56 | Data String
57 deriving (Show,Generic)
58
59parens :: String -> String
60parens a
61 | 1 == length (words a) = a
62 | otherwise = "(" ++ a ++ ")"
63
64psType :: Type -> String
65psType = \case
66 Int -> "Int"
67 Int32 -> "Int32"
68 Word -> "Word"
69 Word32 -> "Word32"
70 Float -> "Float"
71 Bool -> "Bool"
72 String -> "String"
73
74 V2 Int -> "V2I"
75 V2 Word -> "V2U"
76 V2 Float -> "V2F"
77 V2 Bool -> "V2B"
78 V2 (V2 Float) -> "M22F"
79 V2 (V3 Float) -> "M32F"
80 V2 (V4 Float) -> "M42F"
81
82 V3 Int -> "V3I"
83 V3 Word -> "V3U"
84 V3 Float -> "V3F"
85 V3 Bool -> "V3B"
86 V3 (V2 Float) -> "M23F"
87 V3 (V3 Float) -> "M33F"
88 V3 (V4 Float) -> "M43F"
89
90 V4 Int -> "V4I"
91 V4 Word -> "V4U"
92 V4 Float -> "V4F"
93 V4 Bool -> "V4B"
94 V4 (V2 Float) -> "M24F"
95 V4 (V3 Float) -> "M34F"
96 V4 (V4 Float) -> "M44F"
97
98 Array t -> "Array " ++ parens (hsType t)
99 List t -> "List " ++ parens (hsType t)
100 Tuple l -> "(" ++ intercalate "," (map hsType l) ++ ")"
101 Maybe t -> "Maybe " ++ parens (hsType t)
102 Map String v -> "StrMap " ++ parens (hsType v)
103 Map k v -> "Map " ++ parens (hsType k) ++ " " ++ parens (hsType v)
104 -- user defined
105 Data t -> t
106 x -> error $ "unknown type: " ++ show x
107
108hsType :: Type -> String
109hsType = \case
110 Int -> "Int"
111 Int32 -> "Int32"
112 Word -> "Word"
113 Word32 -> "Word32"
114 Float -> "Float"
115 Bool -> "Bool"
116 String -> "String"
117
118 V2 Int -> "V2I"
119 V2 Word -> "V2U"
120 V2 Float -> "V2F"
121 V2 Bool -> "V2B"
122 V2 (V2 Float) -> "M22F"
123 V2 (V3 Float) -> "M32F"
124 V2 (V4 Float) -> "M42F"
125
126 V3 Int -> "V3I"
127 V3 Word -> "V3U"
128 V3 Float -> "V3F"
129 V3 Bool -> "V3B"
130 V3 (V2 Float) -> "M23F"
131 V3 (V3 Float) -> "M33F"
132 V3 (V4 Float) -> "M43F"
133
134 V4 Int -> "V4I"
135 V4 Word -> "V4U"
136 V4 Float -> "V4F"
137 V4 Bool -> "V4B"
138 V4 (V2 Float) -> "M24F"
139 V4 (V3 Float) -> "M34F"
140 V4 (V4 Float) -> "M44F"
141
142 Array t -> "[" ++ hsType t ++ "]"
143 List t -> "[" ++ hsType t ++ "]"
144 Tuple l -> "(" ++ intercalate "," (map hsType l) ++ ")"
145 Maybe t -> "Maybe " ++ parens (hsType t)
146 Map k v -> "Map " ++ parens (hsType k) ++ " " ++ parens (hsType v)
147 -- user defined
148 Data t -> t
149 x -> error $ "unknown type: " ++ show x
150
151hasFieldNames :: [Field] -> Bool
152hasFieldNames [] = False
153hasFieldNames l = all (not . null . fieldName) l
154
155constType :: DataDef -> String
156constType = head . words . show
157
158instance ToJSON ConstructorDef
159instance ToJSON DataDef
160instance ToJSON Field
161instance ToJSON Type
162
163instance FromJSON ConstructorDef
164instance FromJSON DataDef
165instance FromJSON Field
166instance FromJSON Type
167
168type DDef = Writer [DataDef]
169type CDef = Writer [ConstructorDef]
170
171data_ :: forall a . String -> CDef () -> DDef ()
172data_ n l = tell [DataDef n $ execWriter l]
173
174alias_ :: String -> Type -> DDef ()
175alias_ n t = tell [TypeAlias n t]
176
177a #= b = alias_ a b
178
179class IsField a where
180 toField :: a -> Field
181
182instance IsField Field where
183 toField a = a
184
185instance IsField Type where
186 toField a = Field "" a
187
188const_ :: String -> [Type] -> CDef ()
189const_ n t = tell [ConstructorDef n [Field a b | Field a b <- map toField t]]
190
191constR_ :: String -> [Field] -> CDef ()
192constR_ n t = tell [ConstructorDef n [Field a b | Field a b <- map toField t]]
193
194enum_ :: String -> CDef ()
195enum_ n = tell [ConstructorDef n []]
196
197v2b = V2 Bool
198v3b = V3 Bool
199v4b = V4 Bool
200v2u = V2 Word
201v3u = V3 Word
202v4u = V4 Word
203v2i = V2 Int
204v3i = V3 Int
205v4i = V4 Int
206v2f = V2 Float
207v3f = V3 Float
208v4f = V4 Float
209m22 = V2 v2f
210m23 = V3 v2f
211m24 = V4 v2f
212m32 = V2 v3f
213m33 = V3 v3f
214m34 = V4 v3f
215m42 = V2 v4f
216m43 = V3 v4f
217m44 = V4 v4f
218
219(#::) :: String -> Type -> Field
220a #:: b = Field a b
221
222{-
223 definitions:
224 ADT
225 Record
226 Vector
227
228 instances:
229 Show
230 Eq
231 Ord
232
233 serialization:
234 json: encode/decode
235 other?
236-} \ No newline at end of file
diff --git a/templates/data.hs.ede b/templates/data.hs.ede
new file mode 100644
index 0000000..b2ad9de
--- /dev/null
+++ b/templates/data.hs.ede
@@ -0,0 +1,27 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4module {{ moduleName }} where
5
6import Data.Int
7import Data.Word
8import Data.Map
9import Linear
10
11{% for t in dataAndType %}
12{% case t.value | constType %}
13{% when "DataDef" %}
14data {{ t.value.dataName }}{% for c in t.value.constructors %}
15{% if c.value.fields | hasFieldNames %}
16 {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}
17{% for f in c.value.fields %}{% if f.first %} { {%else%} , {%endif%}{{ f.value.fieldName }} :: {{ f.value.fieldType | hsType }}
18{% endfor %}
19 }
20{% else %}
21 {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}{% for f in c.value.fields %} {{ f.value.fieldType | hsType | parens }}{% endfor %}{% endif %}{% endfor %}
22 deriving (Show, Eq, Ord)
23{% when "TypeAlias" %}
24type {{ t.value.aliasName }} = {{ t.value.aliasType | hsType }}
25{% endcase %}
26
27{% endfor %}
diff --git a/templates/data.purs.ede b/templates/data.purs.ede
new file mode 100644
index 0000000..ccaa7de
--- /dev/null
+++ b/templates/data.purs.ede
@@ -0,0 +1,16 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4module {{ moduleName }} where
5
6{% for t in definitions %}
7data {{ t.value.dataName }}{% for c in t.value.constructors %}
8{% if c.value.fields | hasFieldNames %}
9 {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}
10{% for f in c.value.fields %}{% if f.first %} { {%else%} , {%endif%}{{ f.value.fieldName }} :: {{ f.value.fieldType | psType }}
11{% endfor %}
12 }
13{% else %}
14 {% if c.first %}={% else %}|{% endif %} {{ c.value.name }}{% for f in c.value.fields %} {{ f.value.fieldType | psType | parens }}{% endfor %}{% endif %}{% endfor %}
15
16{% endfor %}
diff --git a/templates/decode.hs.ede b/templates/decode.hs.ede
new file mode 100644
index 0000000..743bb39
--- /dev/null
+++ b/templates/decode.hs.ede
@@ -0,0 +1,26 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4{-# LANGUAGE OverloadedStrings #-}
5module {{ moduleName }}Decode where
6
7import Data.Text
8import Data.Aeson hiding (Value,Bool)
9import Control.Monad
10import Linear
11import {{ moduleName }}
12
13{% for t in definitions %}
14instance FromJSON {{ t.value.dataName }} where
15 parseJSON (Object obj) = do
16 tag <- obj .: "tag"
17 case tag :: Text of{% for c in t.value.constructors %}{% if c.value.fields | hasFieldNames %}
18 "{{ c.value.name }}" -> do{% for f in c.value.fields %}
19 {{ f.value.fieldName }} <- obj .: "{{ f.value.fieldName }}"{% endfor %}
20 pure $ {{ c.value.name }}{% for f in c.value.fields %}
21 {% if f.first %}{ {% else %}, {%endif%}{{ f.value.fieldName }} = {{ f.value.fieldName }}{% endfor %}
22 } {% else %}
23 "{{ c.value.name }}" -> {% for f in c.value.fields %}{% if f.first %}{{ c.value.name }} <$>{% else %} <*>{% endif %} obj .: "arg{{ f.index0 }}"{%else%}pure {{ c.value.name }}{% endfor %}{% endif %}{% endfor %}
24 parseJSON _ = mzero
25
26{% endfor %} \ No newline at end of file
diff --git a/templates/decode.purs.ede b/templates/decode.purs.ede
new file mode 100644
index 0000000..d5390a9
--- /dev/null
+++ b/templates/decode.purs.ede
@@ -0,0 +1,19 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4module {{ moduleName }}Decode where
5
6{% for t in definitions %}
7instance decodeJson{{ t.value.dataName }} :: DecodeJson {{ t.value.dataName }} where
8 decodeJson json = do
9 obj <- decodeJson json
10 tag <- obj .? "tag"
11 case tag of{% for c in t.value.constructors %}{% if c.value.fields | hasFieldNames %}
12 "{{ c.value.name }}" -> do{% for f in c.value.fields %}
13 {{ f.value.fieldName }} <- obj .? "{{ f.value.fieldName }}"{% endfor %}
14 pure $ {{ c.value.name }}{% for f in c.value.fields %}
15 {% if f.first %}{ {% else %}, {%endif%}{{ f.value.fieldName }}:{{ f.value.fieldName }}{% endfor %}
16 } {% else %}
17 "{{ c.value.name }}" -> {{ c.value.name }}{% for f in c.value.fields %} {% if f.first %}<$>{% else %}<*>{% endif %} obj .? "arg{{ f.index0 }}"{% endfor %}{% endif %}{% endfor %}
18
19{% endfor %} \ No newline at end of file
diff --git a/templates/encode.hs.ede b/templates/encode.hs.ede
new file mode 100644
index 0000000..f305eb1
--- /dev/null
+++ b/templates/encode.hs.ede
@@ -0,0 +1,26 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
5module {{ moduleName }}Encode where
6
7import Data.Text
8import Data.Aeson hiding (Value,Bool)
9import Data.Aeson.Types hiding (Value,Bool)
10import Linear
11
12import {{ moduleName }}
13
14(.-) :: Text -> Text -> Pair
15a .- b = a .= b
16
17{% for t in definitions %}
18instance ToJSON {{ t.value.dataName }} where
19 toJSON v = case v of{% for c in t.value.constructors %}{% if c.value.fields | hasFieldNames %}
20 {{ c.value.name }}{..} -> object
21 [ "tag" .- "{{ c.value.name }}"{% for f in c.value.fields %}
22 , "{{ f.value.fieldName }}" .= {{ f.value.fieldName }}{% endfor %}
23 ]{% else %}
24 {{ c.value.name }}{% for f in c.value.fields %} arg{{ f.index0 }}{% endfor %} -> object [ "tag" .- "{{ c.value.name }}"{% for f in c.value.fields %}, "arg{{ f.index0 }}" .= arg{{ f.index0 }}{% endfor %}]{% endif %}{% endfor %}
25
26{% endfor %} \ No newline at end of file
diff --git a/templates/encode.purs.ede b/templates/encode.purs.ede
new file mode 100644
index 0000000..e2cfcac
--- /dev/null
+++ b/templates/encode.purs.ede
@@ -0,0 +1,15 @@
1-- generated file, do not modify!
2-- {{ dateTime }}
3
4module {{ moduleName }}Encode where
5
6{% for t in definitions %}
7instance encodeJson{{ t.value.dataName }} :: EncodeJson {{ t.value.dataName }} where
8 encodeJson v = case v of{% for c in t.value.constructors %}{% if c.value.fields | hasFieldNames %}
9 {{ c.value.name }} r ->
10 "tag" := "{{ c.value.name }}" ~>{% for f in c.value.fields %}
11 "{{ f.value.fieldName }}" := r.{{ f.value.fieldName }} ~>{% endfor %}
12 jsonEmptyObject{% else %}
13 {{ c.value.name }}{% for f in c.value.fields %} arg{{ f.index0 }}{% endfor %} -> "tag" := "{{ c.value.name }}"{% for f in c.value.fields %} ~> "arg{{ f.index0 }}" := arg{{ f.index0 }}{% endfor %} ~> jsonEmptyObject{% endif %}{% endfor %}
14
15{% endfor %} \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 14:07:28 +0000