From 4375d1a04c0a270408fb13b68e9587188e9201c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Przemys=C5=82aw=20Lib?= Date: Fri, 9 Mar 2018 12:55:04 +0100 Subject: [PATCH 1/2] Moved types used by tests to CommonTestTypes, unifing them --- swagger2.cabal | 1 + test/Data/Swagger/CommonTestTypes.hs | 652 +++++++++++++++++++++++++++ test/Data/Swagger/ParamSchemaSpec.hs | 83 +--- test/Data/Swagger/SchemaSpec.hs | 633 +------------------------- 4 files changed, 655 insertions(+), 714 deletions(-) create mode 100644 test/Data/Swagger/CommonTestTypes.hs diff --git a/swagger2.cabal b/swagger2.cabal index 695fc29..0bf9c1e 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -105,6 +105,7 @@ test-suite spec other-modules: SpecCommon Data.SwaggerSpec + Data.Swagger.CommonTestTypes Data.Swagger.ParamSchemaSpec Data.Swagger.SchemaSpec Data.Swagger.Schema.ValidationSpec diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs new file mode 100644 index 0000000..521e89b --- /dev/null +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Swagger.CommonTestTypes where + + import Prelude () + import Prelude.Compat + + import Data.Aeson (Value, ToJSON(..), ToJSONKey(..)) + import Data.Aeson.Types (toJSONKeyText) + import Data.Aeson.QQ + import Data.Char + import Data.Proxy + import Data.Set (Set) + import Data.Map (Map) + import qualified Data.Text as Text + import GHC.Generics + + import Data.Swagger + import Data.Swagger.Declare + import Data.Swagger.Internal (SwaggerKind(..)) + + -- ======================================================================== + -- Unit type + -- ======================================================================== + + data Unit = Unit deriving (Generic) + instance ToParamSchema Unit + instance ToSchema Unit + + unitSchemaJSON :: Value + unitSchemaJSON = [aesonQQ| + { + "type": "string", + "enum": ["Unit"] + } + |] + + -- ======================================================================== + -- Color (enum) + -- ======================================================================== + data Color + = Red + | Green + | Blue + deriving (Generic) + instance ToParamSchema Color + instance ToSchema Color + + colorSchemaJSON :: Value + colorSchemaJSON = [aesonQQ| + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + } + |] + + -- ======================================================================== + -- Shade (paramSchemaToNamedSchema) + -- ======================================================================== + + data Shade = Dim | Bright deriving (Generic) + instance ToParamSchema Shade + + instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions + + shadeSchemaJSON :: Value + shadeSchemaJSON = [aesonQQ| + { + "type": "string", + "enum": ["Dim", "Bright"] + } + |] + + -- ======================================================================== + -- Paint (record with bounded enum property) + -- ======================================================================== + + newtype Paint = Paint { color :: Color } + deriving (Generic) + instance ToSchema Paint + + paintSchemaJSON :: Value + paintSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "color": + { + "$ref": "#/definitions/Color" + } + }, + "required": ["color"] + } + |] + + paintInlinedSchemaJSON :: Value + paintInlinedSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "color": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + } + }, + "required": ["color"] + } + |] + + -- ======================================================================== + -- Status (constructorTagModifier) + -- ======================================================================== + + data Status + = StatusOk + | StatusError + deriving (Generic) + + instance ToParamSchema Status where + toParamSchema = genericToParamSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } + instance ToSchema Status where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } + + statusSchemaJSON :: Value + statusSchemaJSON = [aesonQQ| + { + "type": "string", + "enum": ["ok", "error"] + } + |] + + -- ======================================================================== + -- Email (newtype with unwrapUnaryRecords set to True) + -- ======================================================================== + + newtype Email = Email { getEmail :: String } + deriving (Generic) + instance ToParamSchema Email + instance ToSchema Email where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { unwrapUnaryRecords = True } + + emailSchemaJSON :: Value + emailSchemaJSON = [aesonQQ| + { + "type": "string" + } + |] + + -- ======================================================================== + -- UserId (non-record newtype) + -- ======================================================================== + + newtype UserId = UserId Integer + deriving (Eq, Ord, Generic) + instance ToParamSchema UserId + instance ToSchema UserId + + userIdSchemaJSON :: Value + userIdSchemaJSON = [aesonQQ| + { + "type": "integer" + } + |] + + -- ======================================================================== + -- UserGroup (set newtype) + -- ======================================================================== + + newtype UserGroup = UserGroup (Set UserId) + deriving (Generic) + instance ToSchema UserGroup + + userGroupSchemaJSON :: Value + userGroupSchemaJSON = [aesonQQ| + { + "type": "array", + "items": { "$ref": "#/definitions/UserId" }, + "uniqueItems": true + } + |] + + -- ======================================================================== + -- Person (simple record with optional fields) + -- ======================================================================== + data Person = Person + { name :: String + , phone :: Integer + , email :: Maybe String + } deriving (Generic) + + instance ToSchema Person + + personSchemaJSON :: Value + personSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "name": { "type": "string" }, + "phone": { "type": "integer" }, + "email": { "type": "string" } + }, + "required": ["name", "phone"] + } + |] + + -- ======================================================================== + -- Player (record newtype) + -- ======================================================================== + + newtype Player = Player + { position :: Point + } deriving (Generic) + instance ToSchema Player + + playerSchemaJSON :: Value + playerSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + } + |] + + newtype Players = Players [Inlined Player] + deriving (Generic) + instance ToSchema Players + + playersSchemaJSON :: Value + playersSchemaJSON = [aesonQQ| + { + "type": "array", + "items": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + } + } + |] + + -- ======================================================================== + -- Character (sum type with ref and record in alternative) + -- ======================================================================== + + data Character + = PC Player + | NPC { npcName :: String, npcPosition :: Point } + deriving (Generic) + instance ToSchema Character + + characterSchemaJSON :: Value + characterSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "PC": { "$ref": "#/definitions/Player" }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 + } + |] + + characterInlinedSchemaJSON :: Value + characterInlinedSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 + } + |] + + characterInlinedPlayerSchemaJSON :: Value + characterInlinedPlayerSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 + } + |] + + -- ======================================================================== + -- ISPair (non-record product data type) + -- ======================================================================== + data ISPair = ISPair Integer String + deriving (Generic) + + instance ToSchema ISPair + + ispairSchemaJSON :: Value + ispairSchemaJSON = [aesonQQ| + { + "type": "array", + "items": + [ + { "type": "integer" }, + { "type": "string" } + ], + "minItems": 2, + "maxItems": 2 + } + |] + + -- ======================================================================== + -- Point (record data type with custom fieldLabelModifier) + -- ======================================================================== + + data Point = Point + { pointX :: Double + , pointY :: Double + } deriving (Generic) + + instance ToSchema Point where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point") } + + pointSchemaJSON :: Value + pointSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + |] + + -- ======================================================================== + -- Point (record data type with multiple fields) + -- ======================================================================== + + data Point5 = Point5 + { point5X :: Double + , point5Y :: Double + , point5Z :: Double + , point5U :: Double + , point5V :: Double -- 5 dimensional! + } deriving (Generic) + + instance ToSchema Point5 where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point5") } + + point5SchemaJSON :: Value + point5SchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" }, + "z": { "type": "number", "format": "double" }, + "u": { "type": "number", "format": "double" }, + "v": { "type": "number", "format": "double" } + }, + "required": ["x", "y", "z", "u", "v"] + } + |] + + point5Properties :: [String] + point5Properties = ["x", "y", "z", "u", "v"] + + -- ======================================================================== + -- MyRoseTree (custom datatypeNameModifier) + -- ======================================================================== + + data MyRoseTree = MyRoseTree + { root :: String + , trees :: [MyRoseTree] + } deriving (Generic) + + instance ToSchema MyRoseTree where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = drop (length "My") } + + myRoseTreeSchemaJSON :: Value + myRoseTreeSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "root": { "type": "string" }, + "trees": + { + "type": "array", + "items": + { + "$ref": "#/definitions/RoseTree" + } + } + }, + "required": ["root", "trees"] + } + |] + + data MyRoseTree' = MyRoseTree' + { root' :: String + , trees' :: [MyRoseTree'] + } deriving (Generic) + + instance ToSchema MyRoseTree' where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = map toLower } + + myRoseTreeSchemaJSON' :: Value + myRoseTreeSchemaJSON' = [aesonQQ| + { + "type": "object", + "properties": + { + "root'": { "type": "string" }, + "trees'": + { + "type": "array", + "items": + { + "$ref": "#/definitions/myrosetree'" + } + } + }, + "required": ["root'", "trees'"] + } + |] + + -- ======================================================================== + -- Inlined (newtype for inlining schemas) + -- ======================================================================== + + newtype Inlined a = Inlined { getInlined :: a } + + instance ToSchema a => ToSchema (Inlined a) where + declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) + where + unname (NamedSchema _ s) = NamedSchema Nothing s + + -- ======================================================================== + -- Light (sum type with unwrapUnaryRecords) + -- ======================================================================== + + data Light + = NoLight + | LightFreq Double + | LightColor Color + | LightWaveLength { waveLength :: Double } + deriving (Generic) + + instance ToSchema Light where + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + { unwrapUnaryRecords = True } + + lightSchemaJSON :: Value + lightSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": { "$ref": "#/definitions/Color" }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 + } + |] + + lightInlinedSchemaJSON :: Value + lightInlinedSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 + } + |] + + -- ======================================================================== + -- ResourceId (series of newtypes) + -- ======================================================================== + + newtype Id = Id String deriving (Generic) + instance ToSchema Id + + newtype ResourceId = ResourceId Id deriving (Generic) + instance ToSchema ResourceId + + -- ======================================================================== + -- ButtonImages (bounded enum key mapping) + -- ======================================================================== + + data ButtonState = Neutral | Focus | Active | Hover | Disabled + deriving (Show, Bounded, Enum, Generic) + + instance ToJSON ButtonState + instance ToSchema ButtonState + instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) + + type ImageUrl = Text.Text + + newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } + deriving (Generic) + + instance ToJSON ButtonImages where + toJSON = toJSON . getButtonImages + + instance ToSchema ButtonImages where + declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions + declareSchemaBoundedEnumKeyMapping + + buttonImagesSchemaJSON :: Value + buttonImagesSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "Neutral": { "type": "string" }, + "Focus": { "type": "string" }, + "Active": { "type": "string" }, + "Hover": { "type": "string" }, + "Disabled": { "type": "string" } + } + } + |] + + -- ======================================================================== + -- SingleMaybeField (single field data with optional field) + -- ======================================================================== + + data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String } + deriving (Show, Generic) + + instance ToJSON SingleMaybeField + instance ToSchema SingleMaybeField + + singleMaybeFieldSchemaJSON :: Value + singleMaybeFieldSchemaJSON = [aesonQQ| + { + "type": "object", + "properties": + { + "singleMaybeField": { "type": "string" } + } + } + |] diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index aea7390..c02ac64 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -14,6 +14,7 @@ import GHC.Generics import Data.Swagger import Data.Swagger.Internal (SwaggerKind(..)) +import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec @@ -32,85 +33,3 @@ spec = do main :: IO () main = hspec spec - --- ======================================================================== --- Unit type --- ======================================================================== - -data Unit = Unit deriving (Generic) -instance ToParamSchema Unit - -unitSchemaJSON :: Value -unitSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Unit"] -} -|] - --- ======================================================================== --- Color (enum) --- ======================================================================== -data Color - = Red - | Green - | Blue - deriving (Generic) -instance ToParamSchema Color - -colorSchemaJSON :: Value -colorSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Red", "Green", "Blue"] -} -|] - --- ======================================================================== --- Status (constructorTagModifier) --- ======================================================================== - -data Status = StatusOk | StatusError deriving (Generic) - -instance ToParamSchema Status where - toParamSchema = genericToParamSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - -statusSchemaJSON :: Value -statusSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["ok", "error"] -} -|] - --- ======================================================================== --- Email (newtype with unwrapUnaryRecords set to True) --- ======================================================================== - -newtype Email = Email { getEmail :: String } - deriving (Generic) -instance ToParamSchema Email - -emailSchemaJSON :: Value -emailSchemaJSON = [aesonQQ| -{ - "type": "string" -} -|] - --- ======================================================================== --- UserId (non-record newtype) --- ======================================================================== - -newtype UserId = UserId Integer - deriving (Generic) -instance ToParamSchema UserId - -userIdSchemaJSON :: Value -userIdSchemaJSON = [aesonQQ| -{ - "type": "integer" -} -|] - diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs index c25386b..ff63fcb 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -22,6 +22,7 @@ import GHC.Generics import Data.Swagger import Data.Swagger.Declare +import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec @@ -112,635 +113,3 @@ spec = do main :: IO () main = hspec spec - --- ======================================================================== --- Person (simple record with optional fields) --- ======================================================================== -data Person = Person - { name :: String - , phone :: Integer - , email :: Maybe String - } deriving (Generic) - -instance ToSchema Person - -personSchemaJSON :: Value -personSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "name": { "type": "string" }, - "phone": { "type": "integer" }, - "email": { "type": "string" } - }, - "required": ["name", "phone"] -} -|] - --- ======================================================================== --- ISPair (non-record product data type) --- ======================================================================== -data ISPair = ISPair Integer String - deriving (Generic) - -instance ToSchema ISPair - -ispairSchemaJSON :: Value -ispairSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": - [ - { "type": "integer" }, - { "type": "string" } - ], - "minItems": 2, - "maxItems": 2 -} -|] - --- ======================================================================== --- Point (record data type with custom fieldLabelModifier) --- ======================================================================== - -data Point = Point - { pointX :: Double - , pointY :: Double - } deriving (Generic) - -instance ToSchema Point where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point") } - -pointSchemaJSON :: Value -pointSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] -} -|] - --- ======================================================================== --- Point (record data type with multiple fields) --- ======================================================================== - -data Point5 = Point5 - { point5X :: Double - , point5Y :: Double - , point5Z :: Double - , point5U :: Double - , point5V :: Double -- 5 dimensional! - } deriving (Generic) - -instance ToSchema Point5 where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point5") } - -point5SchemaJSON :: Value -point5SchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" }, - "z": { "type": "number", "format": "double" }, - "u": { "type": "number", "format": "double" }, - "v": { "type": "number", "format": "double" } - }, - "required": ["x", "y", "z", "u", "v"] -} -|] - -point5Properties :: [String] -point5Properties = ["x", "y", "z", "u", "v"] - --- ======================================================================== --- Color (enum) --- ======================================================================== -data Color - = Red - | Green - | Blue - deriving (Generic) -instance ToSchema Color - -colorSchemaJSON :: Value -colorSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Red", "Green", "Blue"] -} -|] - --- ======================================================================== --- Shade (paramSchemaToNamedSchema) --- ======================================================================== - -data Shade = Dim | Bright deriving (Generic) -instance ToParamSchema Shade - -instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions - -shadeSchemaJSON :: Value -shadeSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Dim", "Bright"] -} -|] - --- ======================================================================== --- Paint (record with bounded enum property) --- ======================================================================== - -newtype Paint = Paint { color :: Color } - deriving (Generic) -instance ToSchema Paint - -paintSchemaJSON :: Value -paintSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "color": - { - "$ref": "#/definitions/Color" - } - }, - "required": ["color"] -} -|] - -paintInlinedSchemaJSON :: Value -paintInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "color": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - } - }, - "required": ["color"] -} -|] - --- ======================================================================== --- Email (newtype with unwrapUnaryRecords set to True) --- ======================================================================== - -newtype Email = Email { getEmail :: String } - deriving (Generic) - -instance ToSchema Email where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { unwrapUnaryRecords = True } - -emailSchemaJSON :: Value -emailSchemaJSON = [aesonQQ| -{ - "type": "string" -} -|] - --- ======================================================================== --- UserId (non-record newtype) --- ======================================================================== - -newtype UserId = UserId Integer - deriving (Eq, Ord, Generic) -instance ToSchema UserId - -userIdSchemaJSON :: Value -userIdSchemaJSON = [aesonQQ| -{ - "type": "integer" -} -|] - --- ======================================================================== --- UserGroup (set newtype) --- ======================================================================== - -newtype UserGroup = UserGroup (Set UserId) - deriving (Generic) -instance ToSchema UserGroup - -userGroupSchemaJSON :: Value -userGroupSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": { "$ref": "#/definitions/UserId" }, - "uniqueItems": true -} -|] - --- ======================================================================== --- Player (record newtype) --- ======================================================================== - -newtype Player = Player - { position :: Point - } deriving (Generic) -instance ToSchema Player - -playerSchemaJSON :: Value -playerSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] -} -|] - --- ======================================================================== --- MyRoseTree (custom datatypeNameModifier) --- ======================================================================== - -data MyRoseTree = MyRoseTree - { root :: String - , trees :: [MyRoseTree] - } deriving (Generic) - -instance ToSchema MyRoseTree where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { datatypeNameModifier = drop (length "My") } - -myRoseTreeSchemaJSON :: Value -myRoseTreeSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "root": { "type": "string" }, - "trees": - { - "type": "array", - "items": - { - "$ref": "#/definitions/RoseTree" - } - } - }, - "required": ["root", "trees"] -} -|] - -data MyRoseTree' = MyRoseTree' - { root' :: String - , trees' :: [MyRoseTree'] - } deriving (Generic) - -instance ToSchema MyRoseTree' where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { datatypeNameModifier = map toLower } - -myRoseTreeSchemaJSON' :: Value -myRoseTreeSchemaJSON' = [aesonQQ| -{ - "type": "object", - "properties": - { - "root'": { "type": "string" }, - "trees'": - { - "type": "array", - "items": - { - "$ref": "#/definitions/myrosetree'" - } - } - }, - "required": ["root'", "trees'"] -} -|] - --- ======================================================================== --- Inlined (newtype for inlining schemas) --- ======================================================================== - -newtype Inlined a = Inlined { getInlined :: a } - -instance ToSchema a => ToSchema (Inlined a) where - declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) - where - unname (NamedSchema _ s) = NamedSchema Nothing s - -newtype Players = Players [Inlined Player] - deriving (Generic) -instance ToSchema Players - -playersSchemaJSON :: Value -playersSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - } -} -|] - --- ======================================================================== --- Status (sum type with unary constructors) --- ======================================================================== - -data Status - = StatusOk String - | StatusError String - deriving (Generic) - -instance ToSchema Status where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - -statusSchemaJSON :: Value -statusSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "ok": { "type": "string" }, - "error": { "type": "string" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- Unit type --- ======================================================================== - -data Unit = Unit deriving (Generic) -instance ToSchema Unit - -unitSchemaJSON :: Value -unitSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Unit"] -} -|] - - --- ======================================================================== --- Character (sum type with ref and record in alternative) --- ======================================================================== - -data Character - = PC Player - | NPC { npcName :: String, npcPosition :: Point } - deriving (Generic) -instance ToSchema Character - -characterSchemaJSON :: Value -characterSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": { "$ref": "#/definitions/Player" }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -characterInlinedSchemaJSON :: Value -characterInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -characterInlinedPlayerSchemaJSON :: Value -characterInlinedPlayerSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- Light (sum type with unwrapUnaryRecords) --- ======================================================================== - -data Light - = NoLight - | LightFreq Double - | LightColor Color - | LightWaveLength { waveLength :: Double } - deriving (Generic) - -instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions - { unwrapUnaryRecords = True } - -lightSchemaJSON :: Value -lightSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/definitions/Color" }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -lightInlinedSchemaJSON :: Value -lightInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- ResourceId (series of newtypes) --- ======================================================================== - -newtype Id = Id String deriving (Generic) -instance ToSchema Id - -newtype ResourceId = ResourceId Id deriving (Generic) -instance ToSchema ResourceId - --- ======================================================================== --- ButtonImages (bounded enum key mapping) --- ======================================================================== - -data ButtonState = Neutral | Focus | Active | Hover | Disabled - deriving (Show, Bounded, Enum, Generic) - -instance ToJSON ButtonState -instance ToSchema ButtonState -instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) - -type ImageUrl = Text.Text - -newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } - deriving (Generic) - -instance ToJSON ButtonImages where - toJSON = toJSON . getButtonImages - -instance ToSchema ButtonImages where - declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions - declareSchemaBoundedEnumKeyMapping - -buttonImagesSchemaJSON :: Value -buttonImagesSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "Neutral": { "type": "string" }, - "Focus": { "type": "string" }, - "Active": { "type": "string" }, - "Hover": { "type": "string" }, - "Disabled": { "type": "string" } - } -} -|] - - --- ======================================================================== --- SingleMaybeField (single field data with optional field) --- ======================================================================== - -data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String } - deriving (Show, Generic) - -instance ToJSON SingleMaybeField -instance ToSchema SingleMaybeField - -singleMaybeFieldSchemaJSON :: Value -singleMaybeFieldSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "singleMaybeField": { "type": "string" } - } -} -|] From cc2bafbfc58fa2286c7b0ae2abfec25d6121ff11 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Przemys=C5=82aw=20Lib?= Date: Mon, 12 Mar 2018 15:30:24 +0100 Subject: [PATCH 2/2] Removed extra intendation in CommonTestTypes --- test/Data/Swagger/CommonTestTypes.hs | 1292 +++++++++++++------------- 1 file changed, 646 insertions(+), 646 deletions(-) diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs index 521e89b..d5c8981 100644 --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -4,649 +4,649 @@ module Data.Swagger.CommonTestTypes where - import Prelude () - import Prelude.Compat - - import Data.Aeson (Value, ToJSON(..), ToJSONKey(..)) - import Data.Aeson.Types (toJSONKeyText) - import Data.Aeson.QQ - import Data.Char - import Data.Proxy - import Data.Set (Set) - import Data.Map (Map) - import qualified Data.Text as Text - import GHC.Generics - - import Data.Swagger - import Data.Swagger.Declare - import Data.Swagger.Internal (SwaggerKind(..)) - - -- ======================================================================== - -- Unit type - -- ======================================================================== - - data Unit = Unit deriving (Generic) - instance ToParamSchema Unit - instance ToSchema Unit - - unitSchemaJSON :: Value - unitSchemaJSON = [aesonQQ| - { - "type": "string", - "enum": ["Unit"] - } - |] - - -- ======================================================================== - -- Color (enum) - -- ======================================================================== - data Color - = Red - | Green - | Blue - deriving (Generic) - instance ToParamSchema Color - instance ToSchema Color - - colorSchemaJSON :: Value - colorSchemaJSON = [aesonQQ| - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - } - |] - - -- ======================================================================== - -- Shade (paramSchemaToNamedSchema) - -- ======================================================================== - - data Shade = Dim | Bright deriving (Generic) - instance ToParamSchema Shade - - instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions - - shadeSchemaJSON :: Value - shadeSchemaJSON = [aesonQQ| - { - "type": "string", - "enum": ["Dim", "Bright"] - } - |] - - -- ======================================================================== - -- Paint (record with bounded enum property) - -- ======================================================================== - - newtype Paint = Paint { color :: Color } - deriving (Generic) - instance ToSchema Paint - - paintSchemaJSON :: Value - paintSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "color": - { - "$ref": "#/definitions/Color" - } - }, - "required": ["color"] - } - |] - - paintInlinedSchemaJSON :: Value - paintInlinedSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "color": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - } - }, - "required": ["color"] - } - |] - - -- ======================================================================== - -- Status (constructorTagModifier) - -- ======================================================================== - - data Status - = StatusOk - | StatusError - deriving (Generic) - - instance ToParamSchema Status where - toParamSchema = genericToParamSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - instance ToSchema Status where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - - statusSchemaJSON :: Value - statusSchemaJSON = [aesonQQ| - { - "type": "string", - "enum": ["ok", "error"] - } - |] - - -- ======================================================================== - -- Email (newtype with unwrapUnaryRecords set to True) - -- ======================================================================== - - newtype Email = Email { getEmail :: String } - deriving (Generic) - instance ToParamSchema Email - instance ToSchema Email where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { unwrapUnaryRecords = True } - - emailSchemaJSON :: Value - emailSchemaJSON = [aesonQQ| - { - "type": "string" - } - |] - - -- ======================================================================== - -- UserId (non-record newtype) - -- ======================================================================== - - newtype UserId = UserId Integer - deriving (Eq, Ord, Generic) - instance ToParamSchema UserId - instance ToSchema UserId - - userIdSchemaJSON :: Value - userIdSchemaJSON = [aesonQQ| - { - "type": "integer" - } - |] - - -- ======================================================================== - -- UserGroup (set newtype) - -- ======================================================================== - - newtype UserGroup = UserGroup (Set UserId) - deriving (Generic) - instance ToSchema UserGroup - - userGroupSchemaJSON :: Value - userGroupSchemaJSON = [aesonQQ| - { - "type": "array", - "items": { "$ref": "#/definitions/UserId" }, - "uniqueItems": true - } - |] - - -- ======================================================================== - -- Person (simple record with optional fields) - -- ======================================================================== - data Person = Person - { name :: String - , phone :: Integer - , email :: Maybe String - } deriving (Generic) - - instance ToSchema Person - - personSchemaJSON :: Value - personSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "name": { "type": "string" }, - "phone": { "type": "integer" }, - "email": { "type": "string" } - }, - "required": ["name", "phone"] - } - |] - - -- ======================================================================== - -- Player (record newtype) - -- ======================================================================== - - newtype Player = Player - { position :: Point - } deriving (Generic) - instance ToSchema Player - - playerSchemaJSON :: Value - playerSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - } - |] - - newtype Players = Players [Inlined Player] - deriving (Generic) - instance ToSchema Players - - playersSchemaJSON :: Value - playersSchemaJSON = [aesonQQ| - { - "type": "array", - "items": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - } - } - |] - - -- ======================================================================== - -- Character (sum type with ref and record in alternative) - -- ======================================================================== - - data Character - = PC Player - | NPC { npcName :: String, npcPosition :: Point } - deriving (Generic) - instance ToSchema Character - - characterSchemaJSON :: Value - characterSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "PC": { "$ref": "#/definitions/Player" }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 - } - |] - - characterInlinedSchemaJSON :: Value - characterInlinedSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 - } - |] - - characterInlinedPlayerSchemaJSON :: Value - characterInlinedPlayerSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 - } - |] - - -- ======================================================================== - -- ISPair (non-record product data type) - -- ======================================================================== - data ISPair = ISPair Integer String - deriving (Generic) - - instance ToSchema ISPair - - ispairSchemaJSON :: Value - ispairSchemaJSON = [aesonQQ| - { - "type": "array", - "items": - [ - { "type": "integer" }, - { "type": "string" } - ], - "minItems": 2, - "maxItems": 2 - } - |] - - -- ======================================================================== - -- Point (record data type with custom fieldLabelModifier) - -- ======================================================================== - - data Point = Point - { pointX :: Double - , pointY :: Double - } deriving (Generic) - - instance ToSchema Point where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point") } - - pointSchemaJSON :: Value - pointSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - |] - - -- ======================================================================== - -- Point (record data type with multiple fields) - -- ======================================================================== - - data Point5 = Point5 - { point5X :: Double - , point5Y :: Double - , point5Z :: Double - , point5U :: Double - , point5V :: Double -- 5 dimensional! - } deriving (Generic) - - instance ToSchema Point5 where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point5") } - - point5SchemaJSON :: Value - point5SchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" }, - "z": { "type": "number", "format": "double" }, - "u": { "type": "number", "format": "double" }, - "v": { "type": "number", "format": "double" } - }, - "required": ["x", "y", "z", "u", "v"] - } - |] - - point5Properties :: [String] - point5Properties = ["x", "y", "z", "u", "v"] - - -- ======================================================================== - -- MyRoseTree (custom datatypeNameModifier) - -- ======================================================================== - - data MyRoseTree = MyRoseTree - { root :: String - , trees :: [MyRoseTree] - } deriving (Generic) - - instance ToSchema MyRoseTree where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { datatypeNameModifier = drop (length "My") } - - myRoseTreeSchemaJSON :: Value - myRoseTreeSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "root": { "type": "string" }, - "trees": - { - "type": "array", - "items": - { - "$ref": "#/definitions/RoseTree" - } - } - }, - "required": ["root", "trees"] - } - |] - - data MyRoseTree' = MyRoseTree' - { root' :: String - , trees' :: [MyRoseTree'] - } deriving (Generic) - - instance ToSchema MyRoseTree' where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { datatypeNameModifier = map toLower } - - myRoseTreeSchemaJSON' :: Value - myRoseTreeSchemaJSON' = [aesonQQ| - { - "type": "object", - "properties": - { - "root'": { "type": "string" }, - "trees'": - { - "type": "array", - "items": - { - "$ref": "#/definitions/myrosetree'" - } - } - }, - "required": ["root'", "trees'"] - } - |] - - -- ======================================================================== - -- Inlined (newtype for inlining schemas) - -- ======================================================================== - - newtype Inlined a = Inlined { getInlined :: a } - - instance ToSchema a => ToSchema (Inlined a) where - declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) - where - unname (NamedSchema _ s) = NamedSchema Nothing s - - -- ======================================================================== - -- Light (sum type with unwrapUnaryRecords) - -- ======================================================================== - - data Light - = NoLight - | LightFreq Double - | LightColor Color - | LightWaveLength { waveLength :: Double } - deriving (Generic) - - instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions - { unwrapUnaryRecords = True } - - lightSchemaJSON :: Value - lightSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/definitions/Color" }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 - } - |] - - lightInlinedSchemaJSON :: Value - lightInlinedSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 - } - |] - - -- ======================================================================== - -- ResourceId (series of newtypes) - -- ======================================================================== - - newtype Id = Id String deriving (Generic) - instance ToSchema Id - - newtype ResourceId = ResourceId Id deriving (Generic) - instance ToSchema ResourceId - - -- ======================================================================== - -- ButtonImages (bounded enum key mapping) - -- ======================================================================== - - data ButtonState = Neutral | Focus | Active | Hover | Disabled - deriving (Show, Bounded, Enum, Generic) - - instance ToJSON ButtonState - instance ToSchema ButtonState - instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) - - type ImageUrl = Text.Text - - newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } - deriving (Generic) - - instance ToJSON ButtonImages where - toJSON = toJSON . getButtonImages - - instance ToSchema ButtonImages where - declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions - declareSchemaBoundedEnumKeyMapping - - buttonImagesSchemaJSON :: Value - buttonImagesSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "Neutral": { "type": "string" }, - "Focus": { "type": "string" }, - "Active": { "type": "string" }, - "Hover": { "type": "string" }, - "Disabled": { "type": "string" } - } - } - |] - - -- ======================================================================== - -- SingleMaybeField (single field data with optional field) - -- ======================================================================== - - data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String } - deriving (Show, Generic) - - instance ToJSON SingleMaybeField - instance ToSchema SingleMaybeField - - singleMaybeFieldSchemaJSON :: Value - singleMaybeFieldSchemaJSON = [aesonQQ| - { - "type": "object", - "properties": - { - "singleMaybeField": { "type": "string" } - } - } - |] +import Prelude () +import Prelude.Compat + +import Data.Aeson (Value, ToJSON(..), ToJSONKey(..)) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.QQ +import Data.Char +import Data.Proxy +import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Text as Text +import GHC.Generics + +import Data.Swagger +import Data.Swagger.Declare +import Data.Swagger.Internal (SwaggerKind(..)) + +-- ======================================================================== +-- Unit type +-- ======================================================================== + +data Unit = Unit deriving (Generic) +instance ToParamSchema Unit +instance ToSchema Unit + +unitSchemaJSON :: Value +unitSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Unit"] +} +|] + +-- ======================================================================== +-- Color (enum) +-- ======================================================================== +data Color + = Red + | Green + | Blue + deriving (Generic) +instance ToParamSchema Color +instance ToSchema Color + +colorSchemaJSON :: Value +colorSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Red", "Green", "Blue"] +} +|] + +-- ======================================================================== +-- Shade (paramSchemaToNamedSchema) +-- ======================================================================== + +data Shade = Dim | Bright deriving (Generic) +instance ToParamSchema Shade + +instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions + +shadeSchemaJSON :: Value +shadeSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Dim", "Bright"] +} +|] + +-- ======================================================================== +-- Paint (record with bounded enum property) +-- ======================================================================== + +newtype Paint = Paint { color :: Color } + deriving (Generic) +instance ToSchema Paint + +paintSchemaJSON :: Value +paintSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "$ref": "#/definitions/Color" + } + }, + "required": ["color"] +} +|] + +paintInlinedSchemaJSON :: Value +paintInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + } + }, + "required": ["color"] +} +|] + +-- ======================================================================== +-- Status (constructorTagModifier) +-- ======================================================================== + +data Status + = StatusOk + | StatusError + deriving (Generic) + +instance ToParamSchema Status where + toParamSchema = genericToParamSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } +instance ToSchema Status where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } + +statusSchemaJSON :: Value +statusSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["ok", "error"] +} +|] + +-- ======================================================================== +-- Email (newtype with unwrapUnaryRecords set to True) +-- ======================================================================== + +newtype Email = Email { getEmail :: String } + deriving (Generic) +instance ToParamSchema Email +instance ToSchema Email where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { unwrapUnaryRecords = True } + +emailSchemaJSON :: Value +emailSchemaJSON = [aesonQQ| +{ + "type": "string" +} +|] + +-- ======================================================================== +-- UserId (non-record newtype) +-- ======================================================================== + +newtype UserId = UserId Integer + deriving (Eq, Ord, Generic) +instance ToParamSchema UserId +instance ToSchema UserId + +userIdSchemaJSON :: Value +userIdSchemaJSON = [aesonQQ| +{ + "type": "integer" +} +|] + +-- ======================================================================== +-- UserGroup (set newtype) +-- ======================================================================== + +newtype UserGroup = UserGroup (Set UserId) + deriving (Generic) +instance ToSchema UserGroup + +userGroupSchemaJSON :: Value +userGroupSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": { "$ref": "#/definitions/UserId" }, + "uniqueItems": true +} +|] + +-- ======================================================================== +-- Person (simple record with optional fields) +-- ======================================================================== +data Person = Person + { name :: String + , phone :: Integer + , email :: Maybe String + } deriving (Generic) + +instance ToSchema Person + +personSchemaJSON :: Value +personSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "name": { "type": "string" }, + "phone": { "type": "integer" }, + "email": { "type": "string" } + }, + "required": ["name", "phone"] +} +|] + +-- ======================================================================== +-- Player (record newtype) +-- ======================================================================== + +newtype Player = Player + { position :: Point + } deriving (Generic) +instance ToSchema Player + +playerSchemaJSON :: Value +playerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] +} +|] + +newtype Players = Players [Inlined Player] + deriving (Generic) +instance ToSchema Players + +playersSchemaJSON :: Value +playersSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + } +} +|] + +-- ======================================================================== +-- Character (sum type with ref and record in alternative) +-- ======================================================================== + +data Character + = PC Player + | NPC { npcName :: String, npcPosition :: Point } + deriving (Generic) +instance ToSchema Character + +characterSchemaJSON :: Value +characterSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": { "$ref": "#/definitions/Player" }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +characterInlinedSchemaJSON :: Value +characterInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +characterInlinedPlayerSchemaJSON :: Value +characterInlinedPlayerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- ISPair (non-record product data type) +-- ======================================================================== +data ISPair = ISPair Integer String + deriving (Generic) + +instance ToSchema ISPair + +ispairSchemaJSON :: Value +ispairSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + [ + { "type": "integer" }, + { "type": "string" } + ], + "minItems": 2, + "maxItems": 2 +} +|] + +-- ======================================================================== +-- Point (record data type with custom fieldLabelModifier) +-- ======================================================================== + +data Point = Point + { pointX :: Double + , pointY :: Double + } deriving (Generic) + +instance ToSchema Point where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point") } + +pointSchemaJSON :: Value +pointSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] +} +|] + +-- ======================================================================== +-- Point (record data type with multiple fields) +-- ======================================================================== + +data Point5 = Point5 + { point5X :: Double + , point5Y :: Double + , point5Z :: Double + , point5U :: Double + , point5V :: Double -- 5 dimensional! + } deriving (Generic) + +instance ToSchema Point5 where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point5") } + +point5SchemaJSON :: Value +point5SchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" }, + "z": { "type": "number", "format": "double" }, + "u": { "type": "number", "format": "double" }, + "v": { "type": "number", "format": "double" } + }, + "required": ["x", "y", "z", "u", "v"] +} +|] + +point5Properties :: [String] +point5Properties = ["x", "y", "z", "u", "v"] + +-- ======================================================================== +-- MyRoseTree (custom datatypeNameModifier) +-- ======================================================================== + +data MyRoseTree = MyRoseTree + { root :: String + , trees :: [MyRoseTree] + } deriving (Generic) + +instance ToSchema MyRoseTree where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = drop (length "My") } + +myRoseTreeSchemaJSON :: Value +myRoseTreeSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "root": { "type": "string" }, + "trees": + { + "type": "array", + "items": + { + "$ref": "#/definitions/RoseTree" + } + } + }, + "required": ["root", "trees"] +} +|] + +data MyRoseTree' = MyRoseTree' + { root' :: String + , trees' :: [MyRoseTree'] + } deriving (Generic) + +instance ToSchema MyRoseTree' where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = map toLower } + +myRoseTreeSchemaJSON' :: Value +myRoseTreeSchemaJSON' = [aesonQQ| +{ + "type": "object", + "properties": + { + "root'": { "type": "string" }, + "trees'": + { + "type": "array", + "items": + { + "$ref": "#/definitions/myrosetree'" + } + } + }, + "required": ["root'", "trees'"] +} +|] + +-- ======================================================================== +-- Inlined (newtype for inlining schemas) +-- ======================================================================== + +newtype Inlined a = Inlined { getInlined :: a } + +instance ToSchema a => ToSchema (Inlined a) where + declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) + where + unname (NamedSchema _ s) = NamedSchema Nothing s + +-- ======================================================================== +-- Light (sum type with unwrapUnaryRecords) +-- ======================================================================== + +data Light + = NoLight + | LightFreq Double + | LightColor Color + | LightWaveLength { waveLength :: Double } + deriving (Generic) + +instance ToSchema Light where + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + { unwrapUnaryRecords = True } + +lightSchemaJSON :: Value +lightSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": { "$ref": "#/definitions/Color" }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +lightInlinedSchemaJSON :: Value +lightInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- ResourceId (series of newtypes) +-- ======================================================================== + +newtype Id = Id String deriving (Generic) +instance ToSchema Id + +newtype ResourceId = ResourceId Id deriving (Generic) +instance ToSchema ResourceId + +-- ======================================================================== +-- ButtonImages (bounded enum key mapping) +-- ======================================================================== + +data ButtonState = Neutral | Focus | Active | Hover | Disabled + deriving (Show, Bounded, Enum, Generic) + +instance ToJSON ButtonState +instance ToSchema ButtonState +instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) + +type ImageUrl = Text.Text + +newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } + deriving (Generic) + +instance ToJSON ButtonImages where + toJSON = toJSON . getButtonImages + +instance ToSchema ButtonImages where + declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions + declareSchemaBoundedEnumKeyMapping + +buttonImagesSchemaJSON :: Value +buttonImagesSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "Neutral": { "type": "string" }, + "Focus": { "type": "string" }, + "Active": { "type": "string" }, + "Hover": { "type": "string" }, + "Disabled": { "type": "string" } + } +} +|] + +-- ======================================================================== +-- SingleMaybeField (single field data with optional field) +-- ======================================================================== + +data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String } + deriving (Show, Generic) + +instance ToJSON SingleMaybeField +instance ToSchema SingleMaybeField + +singleMaybeFieldSchemaJSON :: Value +singleMaybeFieldSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "singleMaybeField": { "type": "string" } + } +} +|]