git.iko.soy/typeable/swagger2
on master help sign in
Moved types used by tests to CommonTestTypes, unifing them
4375d1aPrzemysław Lib
swagger2.cabal+1
compare with master
unifiedsplit
@@ -105,6 +105,7 @@ test-suite spec
105 other-modules:
105 other-modules:
106 SpecCommon
106 SpecCommon
107 Data.SwaggerSpec
107 Data.SwaggerSpec
108+ Data.Swagger.CommonTestTypes
108 Data.Swagger.ParamSchemaSpec
109 Data.Swagger.ParamSchemaSpec
109 Data.Swagger.SchemaSpec
110 Data.Swagger.SchemaSpec
110 Data.Swagger.Schema.ValidationSpec
111 Data.Swagger.Schema.ValidationSpec
test/Data/Swagger/CommonTestTypes.hsnew file+652
@@ -0,0 +1,652 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE QuasiQuotes #-}
4+
5+module Data.Swagger.CommonTestTypes where
6+
7+ import Prelude ()
8+ import Prelude.Compat
9+
10+ import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))
11+ import Data.Aeson.Types (toJSONKeyText)
12+ import Data.Aeson.QQ
13+ import Data.Char
14+ import Data.Proxy
15+ import Data.Set (Set)
16+ import Data.Map (Map)
17+ import qualified Data.Text as Text
18+ import GHC.Generics
19+
20+ import Data.Swagger
21+ import Data.Swagger.Declare
22+ import Data.Swagger.Internal (SwaggerKind(..))
23+
24+ -- ========================================================================
25+ -- Unit type
26+ -- ========================================================================
27+
28+ data Unit = Unit deriving (Generic)
29+ instance ToParamSchema Unit
30+ instance ToSchema Unit
31+
32+ unitSchemaJSON :: Value
33+ unitSchemaJSON = [aesonQQ|
34+ {
35+ "type": "string",
36+ "enum": ["Unit"]
37+ }
38+ |]
39+
40+ -- ========================================================================
41+ -- Color (enum)
42+ -- ========================================================================
43+ data Color
44+ = Red
45+ | Green
46+ | Blue
47+ deriving (Generic)
48+ instance ToParamSchema Color
49+ instance ToSchema Color
50+
51+ colorSchemaJSON :: Value
52+ colorSchemaJSON = [aesonQQ|
53+ {
54+ "type": "string",
55+ "enum": ["Red", "Green", "Blue"]
56+ }
57+ |]
58+
59+ -- ========================================================================
60+ -- Shade (paramSchemaToNamedSchema)
61+ -- ========================================================================
62+
63+ data Shade = Dim | Bright deriving (Generic)
64+ instance ToParamSchema Shade
65+
66+ instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
67+
68+ shadeSchemaJSON :: Value
69+ shadeSchemaJSON = [aesonQQ|
70+ {
71+ "type": "string",
72+ "enum": ["Dim", "Bright"]
73+ }
74+ |]
75+
76+ -- ========================================================================
77+ -- Paint (record with bounded enum property)
78+ -- ========================================================================
79+
80+ newtype Paint = Paint { color :: Color }
81+ deriving (Generic)
82+ instance ToSchema Paint
83+
84+ paintSchemaJSON :: Value
85+ paintSchemaJSON = [aesonQQ|
86+ {
87+ "type": "object",
88+ "properties":
89+ {
90+ "color":
91+ {
92+ "$ref": "#/definitions/Color"
93+ }
94+ },
95+ "required": ["color"]
96+ }
97+ |]
98+
99+ paintInlinedSchemaJSON :: Value
100+ paintInlinedSchemaJSON = [aesonQQ|
101+ {
102+ "type": "object",
103+ "properties":
104+ {
105+ "color":
106+ {
107+ "type": "string",
108+ "enum": ["Red", "Green", "Blue"]
109+ }
110+ },
111+ "required": ["color"]
112+ }
113+ |]
114+
115+ -- ========================================================================
116+ -- Status (constructorTagModifier)
117+ -- ========================================================================
118+
119+ data Status
120+ = StatusOk
121+ | StatusError
122+ deriving (Generic)
123+
124+ instance ToParamSchema Status where
125+ toParamSchema = genericToParamSchema defaultSchemaOptions
126+ { constructorTagModifier = map toLower . drop (length "Status") }
127+ instance ToSchema Status where
128+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
129+ { constructorTagModifier = map toLower . drop (length "Status") }
130+
131+ statusSchemaJSON :: Value
132+ statusSchemaJSON = [aesonQQ|
133+ {
134+ "type": "string",
135+ "enum": ["ok", "error"]
136+ }
137+ |]
138+
139+ -- ========================================================================
140+ -- Email (newtype with unwrapUnaryRecords set to True)
141+ -- ========================================================================
142+
143+ newtype Email = Email { getEmail :: String }
144+ deriving (Generic)
145+ instance ToParamSchema Email
146+ instance ToSchema Email where
147+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148+ { unwrapUnaryRecords = True }
149+
150+ emailSchemaJSON :: Value
151+ emailSchemaJSON = [aesonQQ|
152+ {
153+ "type": "string"
154+ }
155+ |]
156+
157+ -- ========================================================================
158+ -- UserId (non-record newtype)
159+ -- ========================================================================
160+
161+ newtype UserId = UserId Integer
162+ deriving (Eq, Ord, Generic)
163+ instance ToParamSchema UserId
164+ instance ToSchema UserId
165+
166+ userIdSchemaJSON :: Value
167+ userIdSchemaJSON = [aesonQQ|
168+ {
169+ "type": "integer"
170+ }
171+ |]
172+
173+ -- ========================================================================
174+ -- UserGroup (set newtype)
175+ -- ========================================================================
176+
177+ newtype UserGroup = UserGroup (Set UserId)
178+ deriving (Generic)
179+ instance ToSchema UserGroup
180+
181+ userGroupSchemaJSON :: Value
182+ userGroupSchemaJSON = [aesonQQ|
183+ {
184+ "type": "array",
185+ "items": { "$ref": "#/definitions/UserId" },
186+ "uniqueItems": true
187+ }
188+ |]
189+
190+ -- ========================================================================
191+ -- Person (simple record with optional fields)
192+ -- ========================================================================
193+ data Person = Person
194+ { name :: String
195+ , phone :: Integer
196+ , email :: Maybe String
197+ } deriving (Generic)
198+
199+ instance ToSchema Person
200+
201+ personSchemaJSON :: Value
202+ personSchemaJSON = [aesonQQ|
203+ {
204+ "type": "object",
205+ "properties":
206+ {
207+ "name": { "type": "string" },
208+ "phone": { "type": "integer" },
209+ "email": { "type": "string" }
210+ },
211+ "required": ["name", "phone"]
212+ }
213+ |]
214+
215+ -- ========================================================================
216+ -- Player (record newtype)
217+ -- ========================================================================
218+
219+ newtype Player = Player
220+ { position :: Point
221+ } deriving (Generic)
222+ instance ToSchema Player
223+
224+ playerSchemaJSON :: Value
225+ playerSchemaJSON = [aesonQQ|
226+ {
227+ "type": "object",
228+ "properties":
229+ {
230+ "position":
231+ {
232+ "$ref": "#/definitions/Point"
233+ }
234+ },
235+ "required": ["position"]
236+ }
237+ |]
238+
239+ newtype Players = Players [Inlined Player]
240+ deriving (Generic)
241+ instance ToSchema Players
242+
243+ playersSchemaJSON :: Value
244+ playersSchemaJSON = [aesonQQ|
245+ {
246+ "type": "array",
247+ "items":
248+ {
249+ "type": "object",
250+ "properties":
251+ {
252+ "position":
253+ {
254+ "$ref": "#/definitions/Point"
255+ }
256+ },
257+ "required": ["position"]
258+ }
259+ }
260+ |]
261+
262+ -- ========================================================================
263+ -- Character (sum type with ref and record in alternative)
264+ -- ========================================================================
265+
266+ data Character
267+ = PC Player
268+ | NPC { npcName :: String, npcPosition :: Point }
269+ deriving (Generic)
270+ instance ToSchema Character
271+
272+ characterSchemaJSON :: Value
273+ characterSchemaJSON = [aesonQQ|
274+ {
275+ "type": "object",
276+ "properties":
277+ {
278+ "PC": { "$ref": "#/definitions/Player" },
279+ "NPC":
280+ {
281+ "type": "object",
282+ "properties":
283+ {
284+ "npcName": { "type": "string" },
285+ "npcPosition": { "$ref": "#/definitions/Point" }
286+ },
287+ "required": ["npcName", "npcPosition"]
288+ }
289+ },
290+ "maxProperties": 1,
291+ "minProperties": 1
292+ }
293+ |]
294+
295+ characterInlinedSchemaJSON :: Value
296+ characterInlinedSchemaJSON = [aesonQQ|
297+ {
298+ "type": "object",
299+ "properties":
300+ {
301+ "PC":
302+ {
303+ "type": "object",
304+ "properties":
305+ {
306+ "position":
307+ {
308+ "type": "object",
309+ "properties":
310+ {
311+ "x": { "type": "number", "format": "double" },
312+ "y": { "type": "number", "format": "double" }
313+ },
314+ "required": ["x", "y"]
315+ }
316+ },
317+ "required": ["position"]
318+ },
319+ "NPC":
320+ {
321+ "type": "object",
322+ "properties":
323+ {
324+ "npcName": { "type": "string" },
325+ "npcPosition":
326+ {
327+ "type": "object",
328+ "properties":
329+ {
330+ "x": { "type": "number", "format": "double" },
331+ "y": { "type": "number", "format": "double" }
332+ },
333+ "required": ["x", "y"]
334+ }
335+ },
336+ "required": ["npcName", "npcPosition"]
337+ }
338+ },
339+ "maxProperties": 1,
340+ "minProperties": 1
341+ }
342+ |]
343+
344+ characterInlinedPlayerSchemaJSON :: Value
345+ characterInlinedPlayerSchemaJSON = [aesonQQ|
346+ {
347+ "type": "object",
348+ "properties":
349+ {
350+ "PC":
351+ {
352+ "type": "object",
353+ "properties":
354+ {
355+ "position":
356+ {
357+ "$ref": "#/definitions/Point"
358+ }
359+ },
360+ "required": ["position"]
361+ },
362+ "NPC":
363+ {
364+ "type": "object",
365+ "properties":
366+ {
367+ "npcName": { "type": "string" },
368+ "npcPosition": { "$ref": "#/definitions/Point" }
369+ },
370+ "required": ["npcName", "npcPosition"]
371+ }
372+ },
373+ "maxProperties": 1,
374+ "minProperties": 1
375+ }
376+ |]
377+
378+ -- ========================================================================
379+ -- ISPair (non-record product data type)
380+ -- ========================================================================
381+ data ISPair = ISPair Integer String
382+ deriving (Generic)
383+
384+ instance ToSchema ISPair
385+
386+ ispairSchemaJSON :: Value
387+ ispairSchemaJSON = [aesonQQ|
388+ {
389+ "type": "array",
390+ "items":
391+ [
392+ { "type": "integer" },
393+ { "type": "string" }
394+ ],
395+ "minItems": 2,
396+ "maxItems": 2
397+ }
398+ |]
399+
400+ -- ========================================================================
401+ -- Point (record data type with custom fieldLabelModifier)
402+ -- ========================================================================
403+
404+ data Point = Point
405+ { pointX :: Double
406+ , pointY :: Double
407+ } deriving (Generic)
408+
409+ instance ToSchema Point where
410+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
411+ { fieldLabelModifier = map toLower . drop (length "point") }
412+
413+ pointSchemaJSON :: Value
414+ pointSchemaJSON = [aesonQQ|
415+ {
416+ "type": "object",
417+ "properties":
418+ {
419+ "x": { "type": "number", "format": "double" },
420+ "y": { "type": "number", "format": "double" }
421+ },
422+ "required": ["x", "y"]
423+ }
424+ |]
425+
426+ -- ========================================================================
427+ -- Point (record data type with multiple fields)
428+ -- ========================================================================
429+
430+ data Point5 = Point5
431+ { point5X :: Double
432+ , point5Y :: Double
433+ , point5Z :: Double
434+ , point5U :: Double
435+ , point5V :: Double -- 5 dimensional!
436+ } deriving (Generic)
437+
438+ instance ToSchema Point5 where
439+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
440+ { fieldLabelModifier = map toLower . drop (length "point5") }
441+
442+ point5SchemaJSON :: Value
443+ point5SchemaJSON = [aesonQQ|
444+ {
445+ "type": "object",
446+ "properties":
447+ {
448+ "x": { "type": "number", "format": "double" },
449+ "y": { "type": "number", "format": "double" },
450+ "z": { "type": "number", "format": "double" },
451+ "u": { "type": "number", "format": "double" },
452+ "v": { "type": "number", "format": "double" }
453+ },
454+ "required": ["x", "y", "z", "u", "v"]
455+ }
456+ |]
457+
458+ point5Properties :: [String]
459+ point5Properties = ["x", "y", "z", "u", "v"]
460+
461+ -- ========================================================================
462+ -- MyRoseTree (custom datatypeNameModifier)
463+ -- ========================================================================
464+
465+ data MyRoseTree = MyRoseTree
466+ { root :: String
467+ , trees :: [MyRoseTree]
468+ } deriving (Generic)
469+
470+ instance ToSchema MyRoseTree where
471+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
472+ { datatypeNameModifier = drop (length "My") }
473+
474+ myRoseTreeSchemaJSON :: Value
475+ myRoseTreeSchemaJSON = [aesonQQ|
476+ {
477+ "type": "object",
478+ "properties":
479+ {
480+ "root": { "type": "string" },
481+ "trees":
482+ {
483+ "type": "array",
484+ "items":
485+ {
486+ "$ref": "#/definitions/RoseTree"
487+ }
488+ }
489+ },
490+ "required": ["root", "trees"]
491+ }
492+ |]
493+
494+ data MyRoseTree' = MyRoseTree'
495+ { root' :: String
496+ , trees' :: [MyRoseTree']
497+ } deriving (Generic)
498+
499+ instance ToSchema MyRoseTree' where
500+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
501+ { datatypeNameModifier = map toLower }
502+
503+ myRoseTreeSchemaJSON' :: Value
504+ myRoseTreeSchemaJSON' = [aesonQQ|
505+ {
506+ "type": "object",
507+ "properties":
508+ {
509+ "root'": { "type": "string" },
510+ "trees'":
511+ {
512+ "type": "array",
513+ "items":
514+ {
515+ "$ref": "#/definitions/myrosetree'"
516+ }
517+ }
518+ },
519+ "required": ["root'", "trees'"]
520+ }
521+ |]
522+
523+ -- ========================================================================
524+ -- Inlined (newtype for inlining schemas)
525+ -- ========================================================================
526+
527+ newtype Inlined a = Inlined { getInlined :: a }
528+
529+ instance ToSchema a => ToSchema (Inlined a) where
530+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
531+ where
532+ unname (NamedSchema _ s) = NamedSchema Nothing s
533+
534+ -- ========================================================================
535+ -- Light (sum type with unwrapUnaryRecords)
536+ -- ========================================================================
537+
538+ data Light
539+ = NoLight
540+ | LightFreq Double
541+ | LightColor Color
542+ | LightWaveLength { waveLength :: Double }
543+ deriving (Generic)
544+
545+ instance ToSchema Light where
546+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
547+ { unwrapUnaryRecords = True }
548+
549+ lightSchemaJSON :: Value
550+ lightSchemaJSON = [aesonQQ|
551+ {
552+ "type": "object",
553+ "properties":
554+ {
555+ "NoLight": { "type": "array", "items": [] },
556+ "LightFreq": { "type": "number", "format": "double" },
557+ "LightColor": { "$ref": "#/definitions/Color" },
558+ "LightWaveLength": { "type": "number", "format": "double" }
559+ },
560+ "maxProperties": 1,
561+ "minProperties": 1
562+ }
563+ |]
564+
565+ lightInlinedSchemaJSON :: Value
566+ lightInlinedSchemaJSON = [aesonQQ|
567+ {
568+ "type": "object",
569+ "properties":
570+ {
571+ "NoLight": { "type": "array", "items": [] },
572+ "LightFreq": { "type": "number", "format": "double" },
573+ "LightColor":
574+ {
575+ "type": "string",
576+ "enum": ["Red", "Green", "Blue"]
577+ },
578+ "LightWaveLength": { "type": "number", "format": "double" }
579+ },
580+ "maxProperties": 1,
581+ "minProperties": 1
582+ }
583+ |]
584+
585+ -- ========================================================================
586+ -- ResourceId (series of newtypes)
587+ -- ========================================================================
588+
589+ newtype Id = Id String deriving (Generic)
590+ instance ToSchema Id
591+
592+ newtype ResourceId = ResourceId Id deriving (Generic)
593+ instance ToSchema ResourceId
594+
595+ -- ========================================================================
596+ -- ButtonImages (bounded enum key mapping)
597+ -- ========================================================================
598+
599+ data ButtonState = Neutral | Focus | Active | Hover | Disabled
600+ deriving (Show, Bounded, Enum, Generic)
601+
602+ instance ToJSON ButtonState
603+ instance ToSchema ButtonState
604+ instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
605+
606+ type ImageUrl = Text.Text
607+
608+ newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
609+ deriving (Generic)
610+
611+ instance ToJSON ButtonImages where
612+ toJSON = toJSON . getButtonImages
613+
614+ instance ToSchema ButtonImages where
615+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
616+ declareSchemaBoundedEnumKeyMapping
617+
618+ buttonImagesSchemaJSON :: Value
619+ buttonImagesSchemaJSON = [aesonQQ|
620+ {
621+ "type": "object",
622+ "properties":
623+ {
624+ "Neutral": { "type": "string" },
625+ "Focus": { "type": "string" },
626+ "Active": { "type": "string" },
627+ "Hover": { "type": "string" },
628+ "Disabled": { "type": "string" }
629+ }
630+ }
631+ |]
632+
633+ -- ========================================================================
634+ -- SingleMaybeField (single field data with optional field)
635+ -- ========================================================================
636+
637+ data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
638+ deriving (Show, Generic)
639+
640+ instance ToJSON SingleMaybeField
641+ instance ToSchema SingleMaybeField
642+
643+ singleMaybeFieldSchemaJSON :: Value
644+ singleMaybeFieldSchemaJSON = [aesonQQ|
645+ {
646+ "type": "object",
647+ "properties":
648+ {
649+ "singleMaybeField": { "type": "string" }
650+ }
651+ }
652+ |]
test/Data/Swagger/ParamSchemaSpec.hs+1−82
@@ -14,6 +14,7 @@ import GHC.Generics
14import Data.Swagger
14import Data.Swagger
15import Data.Swagger.Internal (SwaggerKind(..))
15import Data.Swagger.Internal (SwaggerKind(..))
16
16
17+import Data.Swagger.CommonTestTypes
17import SpecCommon
18import SpecCommon
18import Test.Hspec
19import Test.Hspec
19
20
@@ -32,85 +33,3 @@ spec = do
32
33
33main :: IO ()
34main :: IO ()
34main = hspec spec
35main = hspec spec
35−
36−-- ========================================================================
37−-- Unit type
38−-- ========================================================================
39−
40−data Unit = Unit deriving (Generic)
41−instance ToParamSchema Unit
42−
43−unitSchemaJSON :: Value
44−unitSchemaJSON = [aesonQQ|
45−{
46− "type": "string",
47− "enum": ["Unit"]
48−}
49−|]
50−
51−-- ========================================================================
52−-- Color (enum)
53−-- ========================================================================
54−data Color
55− = Red
56− | Green
57− | Blue
58− deriving (Generic)
59−instance ToParamSchema Color
60−
61−colorSchemaJSON :: Value
62−colorSchemaJSON = [aesonQQ|
63−{
64− "type": "string",
65− "enum": ["Red", "Green", "Blue"]
66−}
67−|]
68−
69−-- ========================================================================
70−-- Status (constructorTagModifier)
71−-- ========================================================================
72−
73−data Status = StatusOk | StatusError deriving (Generic)
74−
75−instance ToParamSchema Status where
76− toParamSchema = genericToParamSchema defaultSchemaOptions
77− { constructorTagModifier = map toLower . drop (length "Status") }
78−
79−statusSchemaJSON :: Value
80−statusSchemaJSON = [aesonQQ|
81−{
82− "type": "string",
83− "enum": ["ok", "error"]
84−}
85−|]
86−
87−-- ========================================================================
88−-- Email (newtype with unwrapUnaryRecords set to True)
89−-- ========================================================================
90−
91−newtype Email = Email { getEmail :: String }
92− deriving (Generic)
93−instance ToParamSchema Email
94−
95−emailSchemaJSON :: Value
96−emailSchemaJSON = [aesonQQ|
97−{
98− "type": "string"
99−}
100−|]
101−
102−-- ========================================================================
103−-- UserId (non-record newtype)
104−-- ========================================================================
105−
106−newtype UserId = UserId Integer
107− deriving (Generic)
108−instance ToParamSchema UserId
109−
110−userIdSchemaJSON :: Value
111−userIdSchemaJSON = [aesonQQ|
112−{
113− "type": "integer"
114−}
115−|]
116−
test/Data/Swagger/SchemaSpec.hs+1−632
@@ -22,6 +22,7 @@ import GHC.Generics
22import Data.Swagger
22import Data.Swagger
23import Data.Swagger.Declare
23import Data.Swagger.Declare
24
24
25+import Data.Swagger.CommonTestTypes
25import SpecCommon
26import SpecCommon
26import Test.Hspec
27import Test.Hspec
27
28
@@ -112,635 +113,3 @@ spec = do
112
113
113main :: IO ()
114main :: IO ()
114main = hspec spec
115main = hspec spec
115−
116−-- ========================================================================
117−-- Person (simple record with optional fields)
118−-- ========================================================================
119−data Person = Person
120− { name :: String
121− , phone :: Integer
122− , email :: Maybe String
123− } deriving (Generic)
124−
125−instance ToSchema Person
126−
127−personSchemaJSON :: Value
128−personSchemaJSON = [aesonQQ|
129−{
130− "type": "object",
131− "properties":
132− {
133− "name": { "type": "string" },
134− "phone": { "type": "integer" },
135− "email": { "type": "string" }
136− },
137− "required": ["name", "phone"]
138−}
139−|]
140−
141−-- ========================================================================
142−-- ISPair (non-record product data type)
143−-- ========================================================================
144−data ISPair = ISPair Integer String
145− deriving (Generic)
146−
147−instance ToSchema ISPair
148−
149−ispairSchemaJSON :: Value
150−ispairSchemaJSON = [aesonQQ|
151−{
152− "type": "array",
153− "items":
154− [
155− { "type": "integer" },
156− { "type": "string" }
157− ],
158− "minItems": 2,
159− "maxItems": 2
160−}
161−|]
162−
163−-- ========================================================================
164−-- Point (record data type with custom fieldLabelModifier)
165−-- ========================================================================
166−
167−data Point = Point
168− { pointX :: Double
169− , pointY :: Double
170− } deriving (Generic)
171−
172−instance ToSchema Point where
173− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
174− { fieldLabelModifier = map toLower . drop (length "point") }
175−
176−pointSchemaJSON :: Value
177−pointSchemaJSON = [aesonQQ|
178−{
179− "type": "object",
180− "properties":
181− {
182− "x": { "type": "number", "format": "double" },
183− "y": { "type": "number", "format": "double" }
184− },
185− "required": ["x", "y"]
186−}
187−|]
188−
189−-- ========================================================================
190−-- Point (record data type with multiple fields)
191−-- ========================================================================
192−
193−data Point5 = Point5
194− { point5X :: Double
195− , point5Y :: Double
196− , point5Z :: Double
197− , point5U :: Double
198− , point5V :: Double -- 5 dimensional!
199− } deriving (Generic)
200−
201−instance ToSchema Point5 where
202− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
203− { fieldLabelModifier = map toLower . drop (length "point5") }
204−
205−point5SchemaJSON :: Value
206−point5SchemaJSON = [aesonQQ|
207−{
208− "type": "object",
209− "properties":
210− {
211− "x": { "type": "number", "format": "double" },
212− "y": { "type": "number", "format": "double" },
213− "z": { "type": "number", "format": "double" },
214− "u": { "type": "number", "format": "double" },
215− "v": { "type": "number", "format": "double" }
216− },
217− "required": ["x", "y", "z", "u", "v"]
218−}
219−|]
220−
221−point5Properties :: [String]
222−point5Properties = ["x", "y", "z", "u", "v"]
223−
224−-- ========================================================================
225−-- Color (enum)
226−-- ========================================================================
227−data Color
228− = Red
229− | Green
230− | Blue
231− deriving (Generic)
232−instance ToSchema Color
233−
234−colorSchemaJSON :: Value
235−colorSchemaJSON = [aesonQQ|
236−{
237− "type": "string",
238− "enum": ["Red", "Green", "Blue"]
239−}
240−|]
241−
242−-- ========================================================================
243−-- Shade (paramSchemaToNamedSchema)
244−-- ========================================================================
245−
246−data Shade = Dim | Bright deriving (Generic)
247−instance ToParamSchema Shade
248−
249−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
250−
251−shadeSchemaJSON :: Value
252−shadeSchemaJSON = [aesonQQ|
253−{
254− "type": "string",
255− "enum": ["Dim", "Bright"]
256−}
257−|]
258−
259−-- ========================================================================
260−-- Paint (record with bounded enum property)
261−-- ========================================================================
262−
263−newtype Paint = Paint { color :: Color }
264− deriving (Generic)
265−instance ToSchema Paint
266−
267−paintSchemaJSON :: Value
268−paintSchemaJSON = [aesonQQ|
269−{
270− "type": "object",
271− "properties":
272− {
273− "color":
274− {
275− "$ref": "#/definitions/Color"
276− }
277− },
278− "required": ["color"]
279−}
280−|]
281−
282−paintInlinedSchemaJSON :: Value
283−paintInlinedSchemaJSON = [aesonQQ|
284−{
285− "type": "object",
286− "properties":
287− {
288− "color":
289− {
290− "type": "string",
291− "enum": ["Red", "Green", "Blue"]
292− }
293− },
294− "required": ["color"]
295−}
296−|]
297−
298−-- ========================================================================
299−-- Email (newtype with unwrapUnaryRecords set to True)
300−-- ========================================================================
301−
302−newtype Email = Email { getEmail :: String }
303− deriving (Generic)
304−
305−instance ToSchema Email where
306− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
307− { unwrapUnaryRecords = True }
308−
309−emailSchemaJSON :: Value
310−emailSchemaJSON = [aesonQQ|
311−{
312− "type": "string"
313−}
314−|]
315−
316−-- ========================================================================
317−-- UserId (non-record newtype)
318−-- ========================================================================
319−
320−newtype UserId = UserId Integer
321− deriving (Eq, Ord, Generic)
322−instance ToSchema UserId
323−
324−userIdSchemaJSON :: Value
325−userIdSchemaJSON = [aesonQQ|
326−{
327− "type": "integer"
328−}
329−|]
330−
331−-- ========================================================================
332−-- UserGroup (set newtype)
333−-- ========================================================================
334−
335−newtype UserGroup = UserGroup (Set UserId)
336− deriving (Generic)
337−instance ToSchema UserGroup
338−
339−userGroupSchemaJSON :: Value
340−userGroupSchemaJSON = [aesonQQ|
341−{
342− "type": "array",
343− "items": { "$ref": "#/definitions/UserId" },
344− "uniqueItems": true
345−}
346−|]
347−
348−-- ========================================================================
349−-- Player (record newtype)
350−-- ========================================================================
351−
352−newtype Player = Player
353− { position :: Point
354− } deriving (Generic)
355−instance ToSchema Player
356−
357−playerSchemaJSON :: Value
358−playerSchemaJSON = [aesonQQ|
359−{
360− "type": "object",
361− "properties":
362− {
363− "position":
364− {
365− "$ref": "#/definitions/Point"
366− }
367− },
368− "required": ["position"]
369−}
370−|]
371−
372−-- ========================================================================
373−-- MyRoseTree (custom datatypeNameModifier)
374−-- ========================================================================
375−
376−data MyRoseTree = MyRoseTree
377− { root :: String
378− , trees :: [MyRoseTree]
379− } deriving (Generic)
380−
381−instance ToSchema MyRoseTree where
382− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
383− { datatypeNameModifier = drop (length "My") }
384−
385−myRoseTreeSchemaJSON :: Value
386−myRoseTreeSchemaJSON = [aesonQQ|
387−{
388− "type": "object",
389− "properties":
390− {
391− "root": { "type": "string" },
392− "trees":
393− {
394− "type": "array",
395− "items":
396− {
397− "$ref": "#/definitions/RoseTree"
398− }
399− }
400− },
401− "required": ["root", "trees"]
402−}
403−|]
404−
405−data MyRoseTree' = MyRoseTree'
406− { root' :: String
407− , trees' :: [MyRoseTree']
408− } deriving (Generic)
409−
410−instance ToSchema MyRoseTree' where
411− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
412− { datatypeNameModifier = map toLower }
413−
414−myRoseTreeSchemaJSON' :: Value
415−myRoseTreeSchemaJSON' = [aesonQQ|
416−{
417− "type": "object",
418− "properties":
419− {
420− "root'": { "type": "string" },
421− "trees'":
422− {
423− "type": "array",
424− "items":
425− {
426− "$ref": "#/definitions/myrosetree'"
427− }
428− }
429− },
430− "required": ["root'", "trees'"]
431−}
432−|]
433−
434−-- ========================================================================
435−-- Inlined (newtype for inlining schemas)
436−-- ========================================================================
437−
438−newtype Inlined a = Inlined { getInlined :: a }
439−
440−instance ToSchema a => ToSchema (Inlined a) where
441− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
442− where
443− unname (NamedSchema _ s) = NamedSchema Nothing s
444−
445−newtype Players = Players [Inlined Player]
446− deriving (Generic)
447−instance ToSchema Players
448−
449−playersSchemaJSON :: Value
450−playersSchemaJSON = [aesonQQ|
451−{
452− "type": "array",
453− "items":
454− {
455− "type": "object",
456− "properties":
457− {
458− "position":
459− {
460− "$ref": "#/definitions/Point"
461− }
462− },
463− "required": ["position"]
464− }
465−}
466−|]
467−
468−-- ========================================================================
469−-- Status (sum type with unary constructors)
470−-- ========================================================================
471−
472−data Status
473− = StatusOk String
474− | StatusError String
475− deriving (Generic)
476−
477−instance ToSchema Status where
478− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
479− { constructorTagModifier = map toLower . drop (length "Status") }
480−
481−statusSchemaJSON :: Value
482−statusSchemaJSON = [aesonQQ|
483−{
484− "type": "object",
485− "properties":
486− {
487− "ok": { "type": "string" },
488− "error": { "type": "string" }
489− },
490− "maxProperties": 1,
491− "minProperties": 1
492−}
493−|]
494−
495−-- ========================================================================
496−-- Unit type
497−-- ========================================================================
498−
499−data Unit = Unit deriving (Generic)
500−instance ToSchema Unit
501−
502−unitSchemaJSON :: Value
503−unitSchemaJSON = [aesonQQ|
504−{
505− "type": "string",
506− "enum": ["Unit"]
507−}
508−|]
509−
510−
511−-- ========================================================================
512−-- Character (sum type with ref and record in alternative)
513−-- ========================================================================
514−
515−data Character
516− = PC Player
517− | NPC { npcName :: String, npcPosition :: Point }
518− deriving (Generic)
519−instance ToSchema Character
520−
521−characterSchemaJSON :: Value
522−characterSchemaJSON = [aesonQQ|
523−{
524− "type": "object",
525− "properties":
526− {
527− "PC": { "$ref": "#/definitions/Player" },
528− "NPC":
529− {
530− "type": "object",
531− "properties":
532− {
533− "npcName": { "type": "string" },
534− "npcPosition": { "$ref": "#/definitions/Point" }
535− },
536− "required": ["npcName", "npcPosition"]
537− }
538− },
539− "maxProperties": 1,
540− "minProperties": 1
541−}
542−|]
543−
544−characterInlinedSchemaJSON :: Value
545−characterInlinedSchemaJSON = [aesonQQ|
546−{
547− "type": "object",
548− "properties":
549− {
550− "PC":
551− {
552− "type": "object",
553− "properties":
554− {
555− "position":
556− {
557− "type": "object",
558− "properties":
559− {
560− "x": { "type": "number", "format": "double" },
561− "y": { "type": "number", "format": "double" }
562− },
563− "required": ["x", "y"]
564− }
565− },
566− "required": ["position"]
567− },
568− "NPC":
569− {
570− "type": "object",
571− "properties":
572− {
573− "npcName": { "type": "string" },
574− "npcPosition":
575− {
576− "type": "object",
577− "properties":
578− {
579− "x": { "type": "number", "format": "double" },
580− "y": { "type": "number", "format": "double" }
581− },
582− "required": ["x", "y"]
583− }
584− },
585− "required": ["npcName", "npcPosition"]
586− }
587− },
588− "maxProperties": 1,
589− "minProperties": 1
590−}
591−|]
592−
593−characterInlinedPlayerSchemaJSON :: Value
594−characterInlinedPlayerSchemaJSON = [aesonQQ|
595−{
596− "type": "object",
597− "properties":
598− {
599− "PC":
600− {
601− "type": "object",
602− "properties":
603− {
604− "position":
605− {
606− "$ref": "#/definitions/Point"
607− }
608− },
609− "required": ["position"]
610− },
611− "NPC":
612− {
613− "type": "object",
614− "properties":
615− {
616− "npcName": { "type": "string" },
617− "npcPosition": { "$ref": "#/definitions/Point" }
618− },
619− "required": ["npcName", "npcPosition"]
620− }
621− },
622− "maxProperties": 1,
623− "minProperties": 1
624−}
625−|]
626−
627−-- ========================================================================
628−-- Light (sum type with unwrapUnaryRecords)
629−-- ========================================================================
630−
631−data Light
632− = NoLight
633− | LightFreq Double
634− | LightColor Color
635− | LightWaveLength { waveLength :: Double }
636− deriving (Generic)
637−
638−instance ToSchema Light where
639− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
640− { unwrapUnaryRecords = True }
641−
642−lightSchemaJSON :: Value
643−lightSchemaJSON = [aesonQQ|
644−{
645− "type": "object",
646− "properties":
647− {
648− "NoLight": { "type": "array", "items": [] },
649− "LightFreq": { "type": "number", "format": "double" },
650− "LightColor": { "$ref": "#/definitions/Color" },
651− "LightWaveLength": { "type": "number", "format": "double" }
652− },
653− "maxProperties": 1,
654− "minProperties": 1
655−}
656−|]
657−
658−lightInlinedSchemaJSON :: Value
659−lightInlinedSchemaJSON = [aesonQQ|
660−{
661− "type": "object",
662− "properties":
663− {
664− "NoLight": { "type": "array", "items": [] },
665− "LightFreq": { "type": "number", "format": "double" },
666− "LightColor":
667− {
668− "type": "string",
669− "enum": ["Red", "Green", "Blue"]
670− },
671− "LightWaveLength": { "type": "number", "format": "double" }
672− },
673− "maxProperties": 1,
674− "minProperties": 1
675−}
676−|]
677−
678−-- ========================================================================
679−-- ResourceId (series of newtypes)
680−-- ========================================================================
681−
682−newtype Id = Id String deriving (Generic)
683−instance ToSchema Id
684−
685−newtype ResourceId = ResourceId Id deriving (Generic)
686−instance ToSchema ResourceId
687−
688−-- ========================================================================
689−-- ButtonImages (bounded enum key mapping)
690−-- ========================================================================
691−
692−data ButtonState = Neutral | Focus | Active | Hover | Disabled
693− deriving (Show, Bounded, Enum, Generic)
694−
695−instance ToJSON ButtonState
696−instance ToSchema ButtonState
697−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
698−
699−type ImageUrl = Text.Text
700−
701−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
702− deriving (Generic)
703−
704−instance ToJSON ButtonImages where
705− toJSON = toJSON . getButtonImages
706−
707−instance ToSchema ButtonImages where
708− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
709− declareSchemaBoundedEnumKeyMapping
710−
711−buttonImagesSchemaJSON :: Value
712−buttonImagesSchemaJSON = [aesonQQ|
713−{
714− "type": "object",
715− "properties":
716− {
717− "Neutral": { "type": "string" },
718− "Focus": { "type": "string" },
719− "Active": { "type": "string" },
720− "Hover": { "type": "string" },
721− "Disabled": { "type": "string" }
722− }
723−}
724−|]
725−
726−
727−-- ========================================================================
728−-- SingleMaybeField (single field data with optional field)
729−-- ========================================================================
730−
731−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
732− deriving (Show, Generic)
733−
734−instance ToJSON SingleMaybeField
735−instance ToSchema SingleMaybeField
736−
737−singleMaybeFieldSchemaJSON :: Value
738−singleMaybeFieldSchemaJSON = [aesonQQ|
739−{
740− "type": "object",
741− "properties":
742− {
743− "singleMaybeField": { "type": "string" }
744− }
745−}
746−|]