@@ -17,6 +17,7 @@ import Control.Lens
1717import Data.Aeson
1818import Data.Char
1919import Data.HashMap.Strict (HashMap)
20+import qualified Data.HashMap.Strict as HashMap
2021import "unordered-containers" Data.HashSet (HashSet)
2122import Data.Int
2223import Data.IntSet (IntSet)
@@ -44,11 +45,6 @@ type NamedSchema = (Maybe String, Schema)
4445-- | Schema definitions, a mapping from schema name to @'Schema'@.
4546type Definitions = HashMap T.Text Schema
4647
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
51−
5248unnamed :: Schema -> NamedSchema
5349unnamed schema = (Nothing, schema)
5450
@@ -74,7 +70,7 @@ unname (_, schema) = (Nothing, schema)
7470-- data Coord = Coord { x :: Double, y :: Double }
7571--
7672-- instance ToSchema Coord where
77−-- toSchemaDefinitions = ([("Coord", schema)], (Just "Coord", schema))
73+-- toSchemaDefinitions = pure (Just "Coord", schema)
7874-- where
7975-- schema = mempty
8076-- & schemaType .~ SwaggerObject
@@ -105,7 +101,9 @@ unname (_, schema) = (Nothing, schema)
105101-- @
106102class ToSchema a where
107103 -- | 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).
109107 toSchemaDefinitions :: proxy a -> (Definitions, NamedSchema)
110108 default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> (Definitions, NamedSchema)
111109 toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
@@ -130,18 +128,22 @@ toSchemaRef proxy = case toNamedSchema proxy of
130128 (_, schema) -> Inline schema
131129
132130class GToSchema (f :: * -> *) where
133− gtoSchemaDefinitions :: SchemaOptions -> proxy f -> Schema -> (Definitions, NamedSchema)
131+ gtoSchemaDefinitions :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (Definitions, NamedSchema)
134132
135−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> NamedSchema
133+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> NamedSchema
136134gtoNamedSchema opts proxy = snd . gtoSchemaDefinitions opts proxy
137135
138−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
136+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> Schema
139137gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
140138
141139instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
142− toSchemaDefinitions _ = plain $ mempty
143− & schemaType .~ SwaggerArray
144− & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
140+ toSchemaDefinitions _ = (defs, unnamed schema)
141+ where
142+ schema = mempty
143+ & schemaType .~ SwaggerArray
144+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
145+
146+ (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
145147
146148instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
147149instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
@@ -163,7 +165,9 @@ instance ToSchema Double where toSchemaDefinitions = plain . paramSchemaToS
163165instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
164166
165167instance ToSchema a => ToSchema (Maybe a) where
166− toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
168+ toSchemaDefinitions _ = (defs, unnamed schema)
169+ where
170+ (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy a)
167171
168172instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
169173
@@ -221,31 +225,36 @@ instance ToSchema a => ToSchema (IntMap a) where
221225 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
222226
223227instance ToSchema a => ToSchema (Map String a) where
224− toSchemaDefinitions _ = plain $ mempty
225− & schemaType .~ SwaggerObject
226− & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
228+ toSchemaDefinitions _ = (defs, unnamed schema)
229+ where
230+ schema = mempty
231+ & schemaType .~ SwaggerObject
232+ & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
233+
234+ (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
227235
228−instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
229−instance ToSchema a => ToSchema (Map TL.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))
237+instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
230238
231−instance ToSchema a => ToSchema (HashMap String a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
232−instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
233−instance ToSchema a => ToSchema (HashMap TL.Text 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))
240+instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
241+instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
234242
235243instance ToSchema a => ToSchema (Set a) where
236− toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy [a])
237− & schemaUniqueItems ?~ True
244+ toSchemaDefinitions _ = (defs, unnamed (schema & schemaUniqueItems ?~ True))
245+ where
246+ (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy [a])
238247
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))
240249
241250instance ToSchema All where toSchemaDefinitions = plain . paramSchemaToSchema
242251instance ToSchema Any where toSchemaDefinitions = plain . paramSchemaToSchema
243252
244−instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
245−instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
246−instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
247−instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
248−instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
253+instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
254+instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
255+instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
256+instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
257+instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
249258
250259-- | Default schema for @'Bounded'@, @'Integral'@ types.
251260toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
@@ -303,37 +312,34 @@ instance GToSchema U1 where
303312 gtoSchemaDefinitions _ _ _ = plain nullarySchema
304313
305314instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
306− gtoSchemaDefinitions opts _ schema = (fdefs <> gdefs, unnamed fschema)
315+ gtoSchemaDefinitions opts _ (defs, schema) = (fdefs, unnamed fschema)
307316 where
308− (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) gschema
309− (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) schema
317+ (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (gdefs, gschema)
318+ (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) (defs, schema)
310319
311320instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
312− gtoSchemaDefinitions opts _ s = (defs, (name, schema))
321+ gtoSchemaDefinitions opts _ (ds, s) = (schemaDefs, (name, schema))
313322 where
314− defs = case name of
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)
318324 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
319325
320326instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
321− gtoSchemaDefinitions opts _ s = (defs, unnamed schema)
327+ gtoSchemaDefinitions opts _ (ds, s) = (defs, unnamed schema)
322328 where
323− (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
329+ (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
324330
325331-- | Single field constructor.
326332instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
327− gtoSchemaDefinitions opts _ s
328− | unwrapUnaryRecords opts = fieldSchemaDefs
333+ gtoSchemaDefinitions opts _ (ds, s)
334+ | unwrapUnaryRecords opts = (fieldDefs, fieldNamedSchema)
329335 | otherwise =
330336 case schema ^. schemaItems of
331− Just (SchemaItemsArray [_]) -> fieldSchemaDefs
332− _ -> unname <$> schemaDefs
337+ Just (SchemaItemsArray [_]) -> (fieldDefs, fieldNamedSchema)
338+ _ -> (defs, unnamed schema)
333339 where
334− (_, (_, schema)) = schemaDefs
335− schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) s
336− fieldSchemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
340+ (defs, (_, schema)) = schemaDefs
341+ schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) (ds, s)
342+ (fieldDefs, fieldNamedSchema) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
337343
338344gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Referenced Schema)
339345gtoSchemaRef opts proxy = case gtoSchemaDefinitions opts proxy mempty of
@@ -346,8 +352,9 @@ appendItem x Nothing = Just (SchemaItemsArray [x])
346352appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
347353appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
348354
349−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> (Definitions, Schema)
350−withFieldSchema opts _ isRequiredField schema = (defs, schema')
355+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
356+ SchemaOptions -> proxy s f -> Bool -> (Definitions, Schema) -> (Definitions, Schema)
357+withFieldSchema opts _ isRequiredField (ds, schema) = (ds <> defs, schema')
351358 where
352359 schema'
353360 | T.null fieldName = schema
@@ -372,14 +379,21 @@ instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) wh
372379 gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
373380
374381instance ToSchema c => GToSchema (K1 i c) where
375− gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
382+ gtoSchemaDefinitions _ _ (ds, _)
383+ | present = (ds, (name, schema))
384+ | otherwise = (ds <> defs <> def, (name, schema))
385+ where
386+ (present, def) = case name of
387+ Nothing -> (False, mempty)
388+ Just n -> (HashMap.member (T.pack n) ds, [(T.pack n, schema)])
389+ (defs, (name, schema)) = toSchemaDefinitions (Proxy :: Proxy c)
376390
377391instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
378− gtoSchemaDefinitions opts _ s
379− | allNullaryToStringTag opts && allNullary = plain (toStringTag sumSchema)
380− | otherwise = (defs, unnamed sumSchema)
392+ gtoSchemaDefinitions opts _ (ds, s)
393+ | allNullaryToStringTag opts && allNullary = (ds, unnamed (toStringTag sumSchema))
394+ | otherwise = (ds <> defs, unnamed sumSchema)
381395 where
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)
383397
384398 toStringTag schema = mempty
385399 & schemaType .~ SwaggerString
@@ -388,7 +402,7 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
388402type AllNullary = All
389403
390404class GSumToSchema f where
391− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> ((AllNullary, Definitions), Schema)
405+ gsumToSchema :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
392406
393407instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
394408 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
399413 (b, s'') = g s'
400414
401415gsumConToSchema :: forall c f proxy. Constructor c =>
402− Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> Schema -> ((AllNullary, Definitions), Schema)
403−gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ schema = ((All isNullary, tagSchemaDefs), schema
416+ Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
417+gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ (defs, schema) = (All isNullary, (defs <> tagSchemaDefs, schema
404418 & schemaType .~ SwaggerObject
405419 & schemaProperties . at tag ?~ tagSchemaRef
406420 & schemaMaxProperties ?~ 1
407− & schemaMinProperties ?~ 1)
421+ & schemaMinProperties ?~ 1))
408422 where
409423 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
410424