@@ -17,6 +17,7 @@ import Control.Lens
17import Data.Aeson
17import Data.Aeson
18import Data.Char
18import Data.Char
19import Data.HashMap.Strict (HashMap)
19import Data.HashMap.Strict (HashMap)
20+import qualified Data.HashMap.Strict as HashMap
20import "unordered-containers" Data.HashSet (HashSet)
21import "unordered-containers" Data.HashSet (HashSet)
21import Data.Int
22import Data.Int
22import Data.IntSet (IntSet)
23import Data.IntSet (IntSet)
@@ -44,11 +45,6 @@ type NamedSchema = (Maybe String, Schema)
44-- | Schema definitions, a mapping from schema name to @'Schema'@.
45-- | Schema definitions, a mapping from schema name to @'Schema'@.
45type Definitions = HashMap T.Text Schema
46type Definitions = HashMap T.Text Schema
47−-- | Annotate @'NamedSchema'@ with its definition if name is present.
48−independent :: NamedSchema -> (Definitions, NamedSchema)
49−independent ns@(Just name, schema) = ([(T.pack name, schema)], ns)
50−independent ns = pure ns
52unnamed :: Schema -> NamedSchema
48unnamed :: Schema -> NamedSchema
53unnamed schema = (Nothing, schema)
49unnamed schema = (Nothing, schema)
@@ -74,7 +70,7 @@ unname (_, schema) = (Nothing, schema)
74-- data Coord = Coord { x :: Double, y :: Double }
70-- data Coord = Coord { x :: Double, y :: Double }
76-- instance ToSchema Coord where
72-- instance ToSchema Coord where
77−-- toSchemaDefinitions = ([("Coord", schema)], (Just "Coord", schema))
73+-- toSchemaDefinitions = pure (Just "Coord", schema)
79-- schema = mempty
75-- schema = mempty
80-- & schemaType .~ SwaggerObject
76-- & schemaType .~ SwaggerObject
@@ -105,7 +101,9 @@ unname (_, schema) = (Nothing, schema)
106class ToSchema a where
102class ToSchema a where
107 -- | Convert a type into an optionally named schema
103 -- | Convert a type into an optionally named schema
108− -- together with all used definitions (including this schema).
104+ -- together with all used definitions.
105+ -- Note that the schema itself is included in definitions
106+ -- only if it is recursive (and thus needs its definition in scope).
109 toSchemaDefinitions :: proxy a -> (Definitions, NamedSchema)
107 toSchemaDefinitions :: proxy a -> (Definitions, NamedSchema)
110 default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> (Definitions, NamedSchema)
108 default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> (Definitions, NamedSchema)
111 toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
109 toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
@@ -130,18 +128,22 @@ toSchemaRef proxy = case toNamedSchema proxy of
130 (_, schema) -> Inline schema
128 (_, schema) -> Inline schema
132class GToSchema (f :: * -> *) where
130class GToSchema (f :: * -> *) where
133− gtoSchemaDefinitions :: SchemaOptions -> proxy f -> Schema -> (Definitions, NamedSchema)
131+ gtoSchemaDefinitions :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (Definitions, NamedSchema)
135−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> NamedSchema
133+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> NamedSchema
136gtoNamedSchema opts proxy = snd . gtoSchemaDefinitions opts proxy
134gtoNamedSchema opts proxy = snd . gtoSchemaDefinitions opts proxy
138−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
136+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> Schema
139gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
137gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
141instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
139instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
142− toSchemaDefinitions _ = plain $ mempty
140+ toSchemaDefinitions _ = (defs, unnamed schema)
143− & schemaType .~ SwaggerArray
143+ & schemaType .~ SwaggerArray
144− & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
144+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
146+ (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
146instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
148instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
147instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
149instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
@@ -163,7 +165,9 @@ instance ToSchema Double where toSchemaDefinitions = plain . paramSchemaToS
163instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
165instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
165instance ToSchema a => ToSchema (Maybe a) where
167instance ToSchema a => ToSchema (Maybe a) where
166− toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
168+ toSchemaDefinitions _ = (defs, unnamed schema)
170+ (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy a)
168instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
172instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
@@ -221,31 +225,36 @@ instance ToSchema a => ToSchema (IntMap a) where
221 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
225 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
223instance ToSchema a => ToSchema (Map String a) where
227instance ToSchema a => ToSchema (Map String a) where
224− toSchemaDefinitions _ = plain $ mempty
228+ toSchemaDefinitions _ = (defs, unnamed schema)
225− & schemaType .~ SwaggerObject
231+ & schemaType .~ SwaggerObject
226− & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
232+ & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
234+ (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
228−instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
236+instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
229−instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
237+instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
231−instance ToSchema a => ToSchema (HashMap String a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
239+instance ToSchema a => ToSchema (HashMap String a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
232−instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
240+instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
233−instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
241+instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
235instance ToSchema a => ToSchema (Set a) where
243instance ToSchema a => ToSchema (Set a) where
236− toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy [a])
244+ toSchemaDefinitions _ = (defs, unnamed (schema & schemaUniqueItems ?~ True))
237− & schemaUniqueItems ?~ True
245+ where
246+ (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy [a])
239−instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Set a))
248+instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set a))
241instance ToSchema All where toSchemaDefinitions = plain . paramSchemaToSchema
250instance ToSchema All where toSchemaDefinitions = plain . paramSchemaToSchema
242instance ToSchema Any where toSchemaDefinitions = plain . paramSchemaToSchema
251instance ToSchema Any where toSchemaDefinitions = plain . paramSchemaToSchema
244−instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
253+instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
245−instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
254+instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
246−instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
255+instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
247−instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
256+instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
248−instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
257+instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
250-- | Default schema for @'Bounded'@, @'Integral'@ types.
259-- | Default schema for @'Bounded'@, @'Integral'@ types.
251toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
260toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
@@ -303,37 +312,34 @@ instance GToSchema U1 where
303 gtoSchemaDefinitions _ _ _ = plain nullarySchema
312 gtoSchemaDefinitions _ _ _ = plain nullarySchema
305instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
314instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
306− gtoSchemaDefinitions opts _ schema = (fdefs <> gdefs, unnamed fschema)
315+ gtoSchemaDefinitions opts _ (defs, schema) = (fdefs, unnamed fschema)
308− (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) gschema
317+ (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (gdefs, gschema)
309− (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) schema
318+ (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) (defs, schema)
311instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
320instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
312− gtoSchemaDefinitions opts _ s = (defs, (name, schema))
321+ gtoSchemaDefinitions opts _ (ds, s) = (schemaDefs, (name, schema))
315− Nothing -> schemaDefs
316− Just n -> [(T.pack n, schema)] <> schemaDefs
317− (schemaDefs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
323+ (schemaDefs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
318 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
324 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
320instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
326instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
321− gtoSchemaDefinitions opts _ s = (defs, unnamed schema)
327+ gtoSchemaDefinitions opts _ (ds, s) = (defs, unnamed schema)
323− (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
329+ (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
325-- | Single field constructor.
331-- | Single field constructor.
326instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
332instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
327− gtoSchemaDefinitions opts _ s
333+ gtoSchemaDefinitions opts _ (ds, s)
328− | unwrapUnaryRecords opts = fieldSchemaDefs
334+ | unwrapUnaryRecords opts = (fieldDefs, fieldNamedSchema)
329 | otherwise =
335 | otherwise =
330 case schema ^. schemaItems of
336 case schema ^. schemaItems of
331− Just (SchemaItemsArray [_]) -> fieldSchemaDefs
337+ Just (SchemaItemsArray [_]) -> (fieldDefs, fieldNamedSchema)
332− _ -> unname <$> schemaDefs
338+ _ -> (defs, unnamed schema)
334− (_, (_, schema)) = schemaDefs
340+ (defs, (_, schema)) = schemaDefs
335− schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) s
341+ schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) (ds, s)
336− fieldSchemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
342+ (fieldDefs, fieldNamedSchema) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
338gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Referenced Schema)
344gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Referenced Schema)
339gtoSchemaRef opts proxy = case gtoSchemaDefinitions opts proxy mempty of
345gtoSchemaRef opts proxy = case gtoSchemaDefinitions opts proxy mempty of
@@ -346,8 +352,9 @@ appendItem x Nothing = Just (SchemaItemsArray [x])
346appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
352appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
347appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
353appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
349−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> (Definitions, Schema)
355+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
356+ SchemaOptions -> proxy s f -> Bool -> (Definitions, Schema) -> (Definitions, Schema)
350−withFieldSchema opts _ isRequiredField schema = (defs, schema')
357+withFieldSchema opts _ isRequiredField (ds, schema) = (ds <> defs, schema')
353 | T.null fieldName = schema
360 | T.null fieldName = schema
@@ -372,14 +379,21 @@ instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) wh
372 gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
379 gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
374instance ToSchema c => GToSchema (K1 i c) where
381instance ToSchema c => GToSchema (K1 i c) where
382+ gtoSchemaDefinitions _ _ (ds, _)
383+ | present = (ds, (name, schema))
384+ | otherwise = (ds <> defs <> def, (name, schema))
386+ (present, def) = case name of
387+ Nothing -> (False, mempty)
388+ Just n -> (HashMap.member (T.pack n) ds, [(T.pack n, schema)])
375− gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
389+ (defs, (name, schema)) = toSchemaDefinitions (Proxy :: Proxy c)
377instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
391instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
378− gtoSchemaDefinitions opts _ s
392+ gtoSchemaDefinitions opts _ (ds, s)
379− | allNullaryToStringTag opts && allNullary = plain (toStringTag sumSchema)
393+ | allNullaryToStringTag opts && allNullary = (ds, unnamed (toStringTag sumSchema))
380− | otherwise = (defs, unnamed sumSchema)
394+ | otherwise = (ds <> defs, unnamed sumSchema)
382− ((All allNullary, defs), sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
396+ (All allNullary, (defs, sumSchema)) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) (ds, s)
384 toStringTag schema = mempty
398 toStringTag schema = mempty
385 & schemaType .~ SwaggerString
399 & schemaType .~ SwaggerString
@@ -388,7 +402,7 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
388type AllNullary = All
402type AllNullary = All
390class GSumToSchema f where
404class GSumToSchema f where
391− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> ((AllNullary, Definitions), Schema)
405+ gsumToSchema :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
393instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
407instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
394 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
408 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
@@ -399,12 +413,12 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
399 (b, s'') = g s'
413 (b, s'') = g s'
401gsumConToSchema :: forall c f proxy. Constructor c =>
415gsumConToSchema :: forall c f proxy. Constructor c =>
402− Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> Schema -> ((AllNullary, Definitions), Schema)
416+ Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
403−gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ schema = ((All isNullary, tagSchemaDefs), schema
417+gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ (defs, schema) = (All isNullary, (defs <> tagSchemaDefs, schema
404 & schemaType .~ SwaggerObject
418 & schemaType .~ SwaggerObject
405 & schemaProperties . at tag ?~ tagSchemaRef
419 & schemaProperties . at tag ?~ tagSchemaRef
406 & schemaMaxProperties ?~ 1
420 & schemaMaxProperties ?~ 1
407− & schemaMinProperties ?~ 1)
421+ & schemaMinProperties ?~ 1))
409 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
423 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))