git.iko.soy/typeable/openapi3
on master help sign in
Implement schemas for sum types
commit73de3166fb941653258714223c9407183b746a4c authorMaxim Koltsov <kolmax94@gmail.com> dateSat 4 Jul 2020, 18:48 (6 years ago) parent27079c7
8 files changed+431−201
compare with master
unifiedsplit
src/Data/Swagger.hs+1−33 src/Data/Swagger/Internal/Schema.hs+78−47 src/Data/Swagger/Internal/Schema/Validation.hs+34−18 src/Data/Swagger/Schema.hs−4 src/Data/Swagger/Schema/Generator.hs+6−4 src/Data/Swagger/SchemaOptions.hs+5−1 test/Data/Swagger/CommonTestTypes.hs+305−92 test/Data/Swagger/Schema/ValidationSpec.hs+2−2
src/Data/Swagger.hs+1−33
@@ -289,39 +289,7 @@ import Data.Swagger.Internal
289289-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person)
290290-- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"}
291291--
292−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
293−-- schema for basic enums like
294−--
295−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
296−-- >>> instance ToSchema SampleEnum
297−-- >>> instance ToJSON SampleEnum
298−--
299−-- and for sum types that have constructors with values
300−--
301−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic
302−-- >>> instance ToSchema SampleSumType
303−-- >>> instance ToJSON SampleSumType
304−--
305−-- we can not derive a valid schema for a mix of the above. The following will result in a type error
306−--
307−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
308−-- >>> instance ToSchema BadMixedType
309−-- ...
310−-- ... error:
311−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
312−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
313−-- ... Swagger does not have a good representation for these types.
314−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
315−-- ... that matches aeson's Generic-based toJSON,
316−-- ... but that's not supported by some Swagger tools.
317−-- ...
318−-- ... In the instance declaration for ‘ToSchema BadMixedType’
319−--
320−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
321−--
322−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
323−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
324−-- >>> instance ToJSON BadMixedType
292+-- TODO mention oneOf
325293--
326294
327295-- $manipulation
src/Data/Swagger/Internal/Schema.hs+78−47
@@ -22,12 +22,13 @@ module Data.Swagger.Internal.Schema where
2222import Prelude ()
2323import Prelude.Compat
2424
25−import Control.Lens
25+import Control.Lens hiding (allOf)
2626import Data.Data.Lens (template)
2727
2828import Control.Monad
2929import Control.Monad.Writer
30−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
30+import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),
31+ ToJSONKeyFunction (..), Value (..))
3132import Data.Char
3233import Data.Data (Data)
3334import Data.Foldable (traverse_)
@@ -41,6 +42,7 @@ import Data.IntSet (IntSet)
4142import Data.IntMap (IntMap)
4243import Data.List.NonEmpty.Compat (NonEmpty)
4344import Data.Map (Map)
45+import Data.Maybe (fromMaybe)
4446import Data.Proxy
4547import Data.Scientific (Scientific)
4648import Data.Fixed (Fixed, HasResolution, Pico)
@@ -135,7 +137,7 @@ class ToSchema a where
135137 -- Note that the schema itself is included in definitions
136138 -- only if it is recursive (and thus needs its definition in scope).
137139 declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
138− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
140+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) =>
139141 Proxy a -> Declare (Definitions Schema) NamedSchema
140142 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
141143
@@ -443,7 +445,9 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain
443445instance ToSchema a => ToSchema (Maybe a) where
444446 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
445447
446−instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
448+instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
449+ -- To match Aeson instance
450+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }
447451
448452instance ToSchema () where
449453 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
@@ -637,32 +641,17 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
637641toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
638642
639643-- | A configurable generic @'Schema'@ creator.
640−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
644+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
641645 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
642−genericDeclareSchema = genericDeclareSchemaUnrestricted
646+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
643647
644648-- | A configurable generic @'NamedSchema'@ creator.
645649-- This function applied to @'defaultSchemaOptions'@
646650-- is used as the default for @'declareNamedSchema'@
647651-- when the type is an instance of @'Generic'@.
648−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
652+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
649653 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
650−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
651−
652−-- | A configurable generic @'Schema'@ creator.
653−--
654−-- Unlike 'genericDeclareSchema' also works for mixed sum types.
655−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
656−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
657−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
658−
659−-- | A configurable generic @'NamedSchema'@ creator.
660−--
661−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
662−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
663−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
664− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
665−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
654+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
666655
667656-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
668657genericNameSchema :: forall a d f.
@@ -791,56 +780,98 @@ instance ( GSumToSchema f
791780 , GSumToSchema g
792781 ) => GToSchema (f :+: g)
793782 where
794− gdeclareNamedSchema = gdeclareNamedSumSchema
783+ -- Aeson does not unwrap unary record in sum types.
784+ gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s
795785
796786gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
797−gdeclareNamedSumSchema opts proxy s
798− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
799− | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
787+gdeclareNamedSumSchema opts proxy _
788+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)
789+ | otherwise = do
790+ (schemas, _) <- runWriterT declareSumSchema
791+ return $ unnamed $ mempty
792+ & type_ ?~ SwaggerObject
793+ & oneOf ?~ (snd <$> schemas)
800794 where
801− declareSumSchema = gsumToSchema opts proxy s
802− (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
795+ declareSumSchema = gsumToSchema opts proxy
796+ (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
803797
804− toStringTag schema = mempty
798+ toStringTag schemas = mempty
805799 & type_ ?~ SwaggerString
806− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
800+ & enum_ ?~ map (String . fst) sumSchemas
807801
808802type AllNullary = All
809803
810804class GSumToSchema (f :: * -> *) where
811− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
805+ gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]
812806
813807instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
814− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
808+ gsumToSchema opts _ =
809+ (<>) <$> gsumToSchema opts (Proxy :: Proxy f) <*> gsumToSchema opts (Proxy :: Proxy g)
815810
811+-- | Convert one component of the sum to schema, to be later combined with @oneOf@.
816812gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
817− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
818−gsumConToSchemaWith ref opts _ schema = schema
819− & type_ ?~ SwaggerObject
820− & properties . at tag ?~ ref
821− & maxProperties ?~ 1
822− & minProperties ?~ 1
813+ Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)
814+gsumConToSchemaWith ref opts _ = (tag, schema)
823815 where
816+ schema = case sumEncoding opts of
817+ TaggedObject tagField contentsField ->
818+ case ref of
819+ -- If subschema is an object and constructor is a record, we add tag directly
820+ -- to the record, as Aeson does it.
821+ Just (Inline sub) | sub ^. type_ == Just SwaggerObject && isRecord -> Inline $ sub
822+ & required <>~ [T.pack tagField]
823+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])
824+
825+ -- If it is not a record, we need to put subschema into "contents" field.
826+ _ | not isRecord -> Inline $ mempty
827+ & type_ ?~ SwaggerObject
828+ & required .~ [T.pack tagField]
829+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])
830+ -- If constructor is nullary, there is no content.
831+ & case ref of
832+ Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])
833+ Nothing -> id
834+
835+ -- In the remaining cases we combine "tag" object and "contents" object using allOf.
836+ _ -> Inline $ mempty
837+ & type_ ?~ SwaggerObject
838+ & allOf ?~ [Inline $ mempty
839+ & type_ ?~ SwaggerObject
840+ & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
841+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])]
842+ & if isRecord
843+ then allOf . _Just <>~ [refOrNullary]
844+ else allOf . _Just <>~ [Inline $ mempty & type_ ?~ SwaggerObject & properties . at (T.pack contentsField) ?~ refOrNullary]
845+ UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.
846+ ObjectWithSingleField -> Inline $ mempty
847+ & type_ ?~ SwaggerObject
848+ & required .~ [tag]
849+ & properties . at tag ?~ refOrNullary
850+ TwoElemArray -> error "unrepresentable in OpenAPI 3"
851+
824852 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
853+ isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)
854+ refOrNullary = fromMaybe (Inline nullarySchema) ref
855+ refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) ref
825856
826857gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
827− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
828−gsumConToSchema opts proxy schema = do
858+ SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]
859+gsumConToSchema opts proxy = do
829860 ref <- gdeclareSchemaRef opts proxy
830− return $ gsumConToSchemaWith ref opts proxy schema
861+ return [gsumConToSchemaWith (Just ref) opts proxy]
831862
832863instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
833− gsumToSchema opts proxy schema = do
864+ gsumToSchema opts proxy = do
834865 tell (All False)
835− lift $ gsumConToSchema opts proxy schema
866+ lift $ gsumConToSchema opts proxy
836867
837868instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
838− gsumToSchema opts proxy schema = do
869+ gsumToSchema opts proxy = do
839870 tell (All False)
840− lift $ gsumConToSchema opts proxy schema
871+ lift $ gsumConToSchema opts proxy
841872
842873instance Constructor c => GSumToSchema (C1 c U1) where
843− gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy
874+ gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy
844875
845876data Proxy2 a b = Proxy2
846877
src/Data/Swagger/Internal/Schema/Validation.hs+34−18
@@ -12,6 +12,7 @@
1212{-# LANGUAGE ScopedTypeVariables #-}
1313{-# LANGUAGE TemplateHaskell #-}
1414{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE ViewPatterns #-}
1516-- |
1617-- Module: Data.Swagger.Internal.Schema.Validation
1718-- Copyright: (c) 2015 GetShopTV
@@ -26,8 +27,8 @@ import Prelude ()
2627import Prelude.Compat
2728
2829import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
30+import Control.Lens hiding (allOf)
31+import Control.Monad (forM, forM_, when)
3132
3233import Data.Aeson hiding (Result)
3334import Data.Aeson.Encode.Pretty (encodePretty)
@@ -473,22 +474,37 @@ inferParamSchemaTypes sch = concat
473474
474475validateSchemaType :: Value -> Validation Schema ()
475476validateSchemaType value = withSchema $ \sch ->
476− case (sch ^. type_, value) of
477− (Just SwaggerNull, Null) -> valid
478− (Just SwaggerBoolean, Bool _) -> valid
479− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
480− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
481− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
482− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
483− (Just SwaggerObject, Object o) -> validateObject o
484− (Nothing, Null) -> valid
485− (Nothing, Bool _) -> valid
486− -- Number by default
487− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
488− (Nothing, String s) -> sub_ paramSchema (validateString s)
489− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
490− (Nothing, Object o) -> validateObject o
491− bad -> invalid $ "expected JSON value of type " ++ showType bad
477+ case sch of
478+ (view oneOf -> Just variants) -> do
479+ res <- forM variants $ \var ->
480+ (True <$ validateWithSchemaRef var value) <|> (return False)
481+ case length $ filter id res of
482+ 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show value
483+ 1 -> valid
484+ _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show value
485+ (view allOf -> Just variants) -> do
486+ -- Default semantics for Validation Monad will abort when at least one
487+ -- variant does not match.
488+ forM_ variants $ \var ->
489+ validateWithSchemaRef var value
490+
491+ _ ->
492+ case (sch ^. type_, value) of
493+ (Just SwaggerNull, Null) -> valid
494+ (Just SwaggerBoolean, Bool _) -> valid
495+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
496+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
497+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
498+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
499+ (Just SwaggerObject, Object o) -> validateObject o
500+ (Nothing, Null) -> valid
501+ (Nothing, Bool _) -> valid
502+ -- Number by default
503+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
504+ (Nothing, String s) -> sub_ paramSchema (validateString s)
505+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
506+ (Nothing, Object o) -> validateObject o
507+ bad -> invalid $ "expected JSON value of type " ++ showType bad
492508
493509validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
494510validateParamSchemaType value = withSchema $ \sch ->
src/Data/Swagger/Schema.hs−4
@@ -32,10 +32,6 @@ module Data.Swagger.Schema (
3232 paramSchemaToNamedSchema,
3333 paramSchemaToSchema,
3434
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
3935 -- * Schema templates
4036 passwordSchema,
4137 binarySchema,
src/Data/Swagger/Schema/Generator.hs+6−4
@@ -30,6 +30,8 @@ import Test.QuickCheck.Property
3030schemaGen :: Definitions Schema -> Schema -> Gen Value
3131schemaGen _ schema
3232 | Just cases <- schema ^. paramSchema . enum_ = elements cases
33+schemaGen defns schema
34+ | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants)
3335schemaGen defns schema =
3436 case schema ^. type_ of
3537 Nothing ->
@@ -94,10 +96,10 @@ schemaGen defns schema =
9496 _ -> return []
9597 x <- sequence $ gens <> additionalGens
9698 return . Object $ M.toHashMap x
97− where
98− dereference :: Definitions a -> Referenced a -> a
99− dereference _ (Inline a) = a
100− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
99+
100+dereference :: Definitions a -> Referenced a -> a
101+dereference _ (Inline a) = a
102+dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
101103
102104genValue :: (ToSchema a) => Proxy a -> Gen Value
103105genValue p =
src/Data/Swagger/SchemaOptions.hs+5−1
@@ -22,6 +22,8 @@ data SchemaOptions = SchemaOptions
2222 , allNullaryToStringTag :: Bool
2323 -- | Hide the field name when a record constructor has only one field, like a newtype.
2424 , unwrapUnaryRecords :: Bool
25+ -- | Specifies how to encode constructors of a sum datatype.
26+ , sumEncoding :: Aeson.SumEncoding
2527 }
2628
2729-- | Default encoding @'SchemaOptions'@.
@@ -33,6 +35,7 @@ data SchemaOptions = SchemaOptions
3335-- , 'datatypeNameModifier' = id
3436-- , 'allNullaryToStringTag' = True
3537-- , 'unwrapUnaryRecords' = False
38+-- , 'sumEncoding' = 'Aeson.defaultTaggedObject'
3639-- }
3740-- @
3841defaultSchemaOptions :: SchemaOptions
@@ -42,6 +45,7 @@ defaultSchemaOptions = SchemaOptions
4245 , datatypeNameModifier = id
4346 , allNullaryToStringTag = True
4447 , unwrapUnaryRecords = False
48+ , sumEncoding = Aeson.defaultTaggedObject
4549 }
4650
4751-- | Convert 'Aeson.Options' to 'SchemaOptions'.
@@ -56,7 +60,6 @@ defaultSchemaOptions = SchemaOptions
5660-- Note that these fields have no effect on `SchemaOptions`:
5761--
5862-- * 'Aeson.omitNothingFields'
59−-- * 'Aeson.sumEncoding'
6063-- * 'Aeson.tagSingleConstructors'
6164--
6265-- The rest is defined as in 'defaultSchemaOptions'.
@@ -69,4 +72,5 @@ fromAesonOptions opts = defaultSchemaOptions
6972 , constructorTagModifier = Aeson.constructorTagModifier opts
7073 , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
7174 , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
75+ , sumEncoding = Aeson.sumEncoding opts
7276 }
test/Data/Swagger/CommonTestTypes.hs+305−92
@@ -271,106 +271,192 @@ instance ToSchema Character
271271characterSchemaJSON :: Value
272272characterSchemaJSON = [aesonQQ|
273273{
274− "type": "object",
275− "properties":
274+ "oneOf": [
276275 {
277− "PC": { "$ref": "#/components/schemas/Player" },
278− "NPC":
279− {
280− "type": "object",
281− "properties":
282− {
283− "npcName": { "type": "string" },
284− "npcPosition": { "$ref": "#/components/schemas/Point" }
285− },
286− "required": ["npcName", "npcPosition"]
276+ "required": [
277+ "tag",
278+ "contents"
279+ ],
280+ "type": "object",
281+ "properties": {
282+ "tag": {
283+ "type": "string",
284+ "enum": [
285+ "PC"
286+ ]
287+ },
288+ "contents": {
289+ "$ref": "#/components/schemas/Player"
287290 }
291+ }
288292 },
289− "maxProperties": 1,
290− "minProperties": 1
293+ {
294+ "required": [
295+ "npcName",
296+ "npcPosition",
297+ "tag"
298+ ],
299+ "type": "object",
300+ "properties": {
301+ "tag": {
302+ "type": "string",
303+ "enum": [
304+ "NPC"
305+ ]
306+ },
307+ "npcPosition": {
308+ "$ref": "#/components/schemas/Point"
309+ },
310+ "npcName": {
311+ "type": "string"
312+ }
313+ }
314+ }
315+ ],
316+ "type": "object"
291317}
318+
292319|]
293320
294321characterInlinedSchemaJSON :: Value
295322characterInlinedSchemaJSON = [aesonQQ|
296323{
297− "type": "object",
298− "properties":
324+ "oneOf": [
299325 {
300− "PC":
301− {
326+ "required": [
327+ "tag",
328+ "contents"
329+ ],
330+ "type": "object",
331+ "properties": {
332+ "tag": {
333+ "type": "string",
334+ "enum": [
335+ "PC"
336+ ]
337+ },
338+ "contents": {
339+ "required": [
340+ "position"
341+ ],
302342 "type": "object",
303− "properties":
304− {
305− "position":
306− {
307− "type": "object",
308− "properties":
309− {
310− "x": { "type": "number", "format": "double" },
311− "y": { "type": "number", "format": "double" }
312− },
313− "required": ["x", "y"]
343+ "properties": {
344+ "position": {
345+ "required": [
346+ "x",
347+ "y"
348+ ],
349+ "type": "object",
350+ "properties": {
351+ "x": {
352+ "format": "double",
353+ "type": "number"
354+ },
355+ "y": {
356+ "format": "double",
357+ "type": "number"
314358 }
315− },
316− "required": ["position"]
359+ }
360+ }
361+ }
362+ }
363+ }
364+ },
365+ {
366+ "required": [
367+ "npcName",
368+ "npcPosition",
369+ "tag"
370+ ],
371+ "type": "object",
372+ "properties": {
373+ "tag": {
374+ "type": "string",
375+ "enum": [
376+ "NPC"
377+ ]
317378 },
318− "NPC":
319− {
379+ "npcPosition": {
380+ "required": [
381+ "x",
382+ "y"
383+ ],
320384 "type": "object",
321− "properties":
322− {
323− "npcName": { "type": "string" },
324− "npcPosition":
325− {
326− "type": "object",
327− "properties":
328− {
329− "x": { "type": "number", "format": "double" },
330− "y": { "type": "number", "format": "double" }
331− },
332− "required": ["x", "y"]
333− }
385+ "properties": {
386+ "x": {
387+ "format": "double",
388+ "type": "number"
334389 },
335− "required": ["npcName", "npcPosition"]
390+ "y": {
391+ "format": "double",
392+ "type": "number"
393+ }
394+ }
395+ },
396+ "npcName": {
397+ "type": "string"
336398 }
337− },
338− "maxProperties": 1,
339− "minProperties": 1
399+ }
400+ }
401+ ],
402+ "type": "object"
340403}
341404|]
342405
343406characterInlinedPlayerSchemaJSON :: Value
344407characterInlinedPlayerSchemaJSON = [aesonQQ|
345408{
346− "type": "object",
347− "properties":
409+ "oneOf": [
348410 {
349− "PC":
350− {
351− "type": "object",
352− "properties":
353− {
354− "position":
355− {
356− "$ref": "#/components/schemas/Point"
357− }
358− },
359− "required": ["position"]
411+ "required": [
412+ "tag",
413+ "contents"
414+ ],
415+ "type": "object",
416+ "properties": {
417+ "tag": {
418+ "type": "string",
419+ "enum": [
420+ "PC"
421+ ]
360422 },
361− "NPC":
362− {
423+ "contents": {
424+ "required": [
425+ "position"
426+ ],
363427 "type": "object",
364− "properties":
365− {
366− "npcName": { "type": "string" },
367− "npcPosition": { "$ref": "#/components/schemas/Point" }
368− },
369− "required": ["npcName", "npcPosition"]
428+ "properties": {
429+ "position": {
430+ "$ref": "#/components/schemas/Point"
431+ }
432+ }
370433 }
434+ }
371435 },
372− "maxProperties": 1,
373− "minProperties": 1
436+ {
437+ "required": [
438+ "npcName",
439+ "npcPosition",
440+ "tag"
441+ ],
442+ "type": "object",
443+ "properties": {
444+ "tag": {
445+ "type": "string",
446+ "enum": [
447+ "NPC"
448+ ]
449+ },
450+ "npcPosition": {
451+ "$ref": "#/components/schemas/Point"
452+ },
453+ "npcName": {
454+ "type": "string"
455+ }
456+ }
457+ }
458+ ],
459+ "type": "object"
374460}
375461|]
376462
@@ -542,42 +628,169 @@ data Light
542628 deriving (Generic)
543629
544630instance ToSchema Light where
545− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
631+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
546632 { unwrapUnaryRecords = True }
547633
548634lightSchemaJSON :: Value
549635lightSchemaJSON = [aesonQQ|
550636{
551− "type": "object",
552− "properties":
637+ "oneOf": [
638+ {
639+ "required": [
640+ "tag"
641+ ],
642+ "type": "object",
643+ "properties": {
644+ "tag": {
645+ "type": "string",
646+ "enum": [
647+ "NoLight"
648+ ]
649+ }
650+ }
651+ },
553652 {
554− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
555− "LightFreq": { "type": "number", "format": "double" },
556− "LightColor": { "$ref": "#/components/schemas/Color" },
557− "LightWaveLength": { "type": "number", "format": "double" }
653+ "required": [
654+ "tag",
655+ "contents"
656+ ],
657+ "type": "object",
658+ "properties": {
659+ "tag": {
660+ "type": "string",
661+ "enum": [
662+ "LightFreq"
663+ ]
664+ },
665+ "contents": {
666+ "format": "double",
667+ "type": "number"
668+ }
669+ }
670+ },
671+ {
672+ "required": [
673+ "tag",
674+ "contents"
675+ ],
676+ "type": "object",
677+ "properties": {
678+ "tag": {
679+ "type": "string",
680+ "enum": [
681+ "LightColor"
682+ ]
683+ },
684+ "contents": {
685+ "$ref": "#/components/schemas/Color"
686+ }
687+ }
558688 },
559− "maxProperties": 1,
560− "minProperties": 1
689+ {
690+ "required": [
691+ "waveLength",
692+ "tag"
693+ ],
694+ "type": "object",
695+ "properties": {
696+ "tag": {
697+ "type": "string",
698+ "enum": [
699+ "LightWaveLength"
700+ ]
701+ },
702+ "waveLength": {
703+ "format": "double",
704+ "type": "number"
705+ }
706+ }
707+ }
708+ ],
709+ "type": "object"
561710}
562711|]
563712
564713lightInlinedSchemaJSON :: Value
565714lightInlinedSchemaJSON = [aesonQQ|
566715{
567− "type": "object",
568− "properties":
716+ "oneOf": [
569717 {
570− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
571− "LightFreq": { "type": "number", "format": "double" },
572− "LightColor":
573− {
718+ "required": [
719+ "tag"
720+ ],
721+ "type": "object",
722+ "properties": {
723+ "tag": {
574724 "type": "string",
575− "enum": ["Red", "Green", "Blue"]
725+ "enum": [
726+ "NoLight"
727+ ]
728+ }
729+ }
730+ },
731+ {
732+ "required": [
733+ "tag",
734+ "contents"
735+ ],
736+ "type": "object",
737+ "properties": {
738+ "tag": {
739+ "type": "string",
740+ "enum": [
741+ "LightFreq"
742+ ]
576743 },
577− "LightWaveLength": { "type": "number", "format": "double" }
744+ "contents": {
745+ "format": "double",
746+ "type": "number"
747+ }
748+ }
578749 },
579− "maxProperties": 1,
580− "minProperties": 1
750+ {
751+ "required": [
752+ "tag",
753+ "contents"
754+ ],
755+ "type": "object",
756+ "properties": {
757+ "tag": {
758+ "type": "string",
759+ "enum": [
760+ "LightColor"
761+ ]
762+ },
763+ "contents": {
764+ "type": "string",
765+ "enum": [
766+ "Red",
767+ "Green",
768+ "Blue"
769+ ]
770+ }
771+ }
772+ },
773+ {
774+ "required": [
775+ "waveLength",
776+ "tag"
777+ ],
778+ "type": "object",
779+ "properties": {
780+ "tag": {
781+ "type": "string",
782+ "enum": [
783+ "LightWaveLength"
784+ ]
785+ },
786+ "waveLength": {
787+ "format": "double",
788+ "type": "number"
789+ }
790+ }
791+ }
792+ ],
793+ "type": "object"
581794}
582795|]
583796
test/Data/Swagger/Schema/ValidationSpec.hs+2−2
@@ -188,10 +188,10 @@ instance Arbitrary MyRoseTree where
188188data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
189189
190190instance ToSchema Light where
191− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
191+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = ObjectWithSingleField }
192192
193193instance ToJSON Light where
194− toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
194+ toJSON = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = ObjectWithSingleField }
195195
196196instance Arbitrary Light where
197197 arbitrary = oneof