git.iko.soy/typeable/swagger2
on master help sign in
Annotate NamedSchema with Definitions (including the schema itself)
f94f8a5Nickolay Kudasov
src/Data/Swagger/Internal/Schema.hs+142−101
compare with master
unifiedsplit
@@ -2,6 +2,7 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedLists #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
@@ -40,40 +41,56 @@ import Data.Swagger.SchemaOptions
40-- This name can be used in references.
41-- This name can be used in references.
41type NamedSchema = (Maybe String, Schema)
42type NamedSchema = (Maybe String, Schema)
42
43
44+-- | Schema definitions, a mapping from schema name to @'Schema'@.
45+type Definitions = HashMap T.Text Schema
46+
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+
43unnamed :: Schema -> NamedSchema
52unnamed :: Schema -> NamedSchema
44unnamed schema = (Nothing, schema)
53unnamed schema = (Nothing, schema)
45
54
46named :: String -> Schema -> NamedSchema
55named :: String -> Schema -> NamedSchema
47named name schema = (Just name, schema)
56named name schema = (Just name, schema)
48
57
58+plain :: Schema -> (Definitions, NamedSchema)
59+plain schema = (mempty, unnamed schema)
60+
61+unname :: NamedSchema -> NamedSchema
62+unname (_, schema) = (Nothing, schema)
63+
49-- | Convert a type into @'Schema'@.
64-- | Convert a type into @'Schema'@.
50--
65--
51-- An example type and instance:
66-- An example type and instance:
52--
67--
53-- @
68-- @
54-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
69-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
55−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list
70+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
56--
71--
57-- import Control.Lens
72-- import Control.Lens
58--
73--
59-- data Coord = Coord { x :: Double, y :: Double }
74-- data Coord = Coord { x :: Double, y :: Double }
60--
75--
61-- instance ToSchema Coord where
76-- instance ToSchema Coord where
62−-- toNamedSchema = (Just \"Coord\", mempty
77+-- toSchemaDefinitions = ([("Coord", schema)], (Just "Coord", schema))
78+-- where
79+-- schema = mempty
63−-- & schemaType .~ SwaggerObject
80+-- & schemaType .~ SwaggerObject
64−-- & schemaProperties .~
81+-- & schemaProperties .~
65−-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
82+-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
66−-- , ("y", toSchemaRef (Proxy :: Proxy Double))
83+-- , ("y", toSchemaRef (Proxy :: Proxy Double))
67−-- ]
84+-- ]
68−-- & schemaRequired .~ [ "x", "y" ]
85+-- & schemaRequired .~ [ "x", "y" ]
69-- @
86-- @
70--
87--
71-- Instead of manually writing your @'ToSchema'@ instance you can
88-- Instead of manually writing your @'ToSchema'@ instance you can
72−-- use a default generic implementation of @'toNamedSchema'@.
89+-- use a default generic implementation of @'toSchemaDefinitions'@.
73--
90--
74-- To do that, simply add @deriving 'Generic'@ clause to your datatype
91-- To do that, simply add @deriving 'Generic'@ clause to your datatype
75-- and declare a @'ToSchema'@ instance for your datatype without
92-- and declare a @'ToSchema'@ instance for your datatype without
76−-- giving definition for @'toNamedSchema'@.
93+-- giving definition for @'toSchemaDefinitions'@.
77--
94--
78-- For instance, the previous example can be simplified into this:
95-- For instance, the previous example can be simplified into this:
79--
96--
@@ -87,10 +104,15 @@ named name schema = (Just name, schema)
87-- instance ToSchema Coord
104-- instance ToSchema Coord
88-- @
105-- @
89class ToSchema a where
106class ToSchema a where
90− -- | Convert a type into an optionally named schema.
107+ -- | Convert a type into an optionally named schema
108+ -- together with all used definitions (including this schema).
91− toNamedSchema :: proxy a -> NamedSchema
109+ toSchemaDefinitions :: proxy a -> (Definitions, NamedSchema)
92− default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
110+ default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> (Definitions, NamedSchema)
93− toNamedSchema = genericToNamedSchema defaultSchemaOptions
111+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
112+
113+-- | Convert a type into an optionally named schema.
114+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
115+toNamedSchema = snd . toSchemaDefinitions
94
116
95-- | Get type's schema name according to its @'ToSchema'@ instance.
117-- | Get type's schema name according to its @'ToSchema'@ instance.
96schemaName :: ToSchema a => proxy a -> Maybe String
118schemaName :: ToSchema a => proxy a -> Maybe String
@@ -108,37 +130,40 @@ toSchemaRef proxy = case toNamedSchema proxy of
108 (_, schema) -> Inline schema
130 (_, schema) -> Inline schema
109
131
110class GToSchema (f :: * -> *) where
132class GToSchema (f :: * -> *) where
133+ gtoSchemaDefinitions :: SchemaOptions -> proxy f -> Schema -> (Definitions, NamedSchema)
134+
111− gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
135+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> NamedSchema
136+gtoNamedSchema opts proxy = snd . gtoSchemaDefinitions opts proxy
112
137
113gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
138gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
114gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
139gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
115
140
116instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
141instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
117− toNamedSchema _ = unnamed $ mempty
142+ toSchemaDefinitions _ = plain $ mempty
118 & schemaType .~ SwaggerArray
143 & schemaType .~ SwaggerArray
119 & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
144 & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
120
145
121−instance {-# OVERLAPPING #-} ToSchema String where toNamedSchema = unnamed . paramSchemaToSchema
146+instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
122−instance ToSchema Bool where toNamedSchema = unnamed . paramSchemaToSchema
147+instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
123−instance ToSchema Integer where toNamedSchema = unnamed . paramSchemaToSchema
148+instance ToSchema Integer where toSchemaDefinitions = plain . paramSchemaToSchema
124−instance ToSchema Int where toNamedSchema = unnamed . paramSchemaToSchema
149+instance ToSchema Int where toSchemaDefinitions = plain . paramSchemaToSchema
125−instance ToSchema Int8 where toNamedSchema = unnamed . paramSchemaToSchema
150+instance ToSchema Int8 where toSchemaDefinitions = plain . paramSchemaToSchema
126−instance ToSchema Int16 where toNamedSchema = unnamed . paramSchemaToSchema
151+instance ToSchema Int16 where toSchemaDefinitions = plain . paramSchemaToSchema
127−instance ToSchema Int32 where toNamedSchema = unnamed . paramSchemaToSchema
152+instance ToSchema Int32 where toSchemaDefinitions = plain . paramSchemaToSchema
128−instance ToSchema Int64 where toNamedSchema = unnamed . paramSchemaToSchema
153+instance ToSchema Int64 where toSchemaDefinitions = plain . paramSchemaToSchema
129−instance ToSchema Word where toNamedSchema = unnamed . paramSchemaToSchema
154+instance ToSchema Word where toSchemaDefinitions = plain . paramSchemaToSchema
130−instance ToSchema Word8 where toNamedSchema = unnamed . paramSchemaToSchema
155+instance ToSchema Word8 where toSchemaDefinitions = plain . paramSchemaToSchema
131−instance ToSchema Word16 where toNamedSchema = unnamed . paramSchemaToSchema
156+instance ToSchema Word16 where toSchemaDefinitions = plain . paramSchemaToSchema
132−instance ToSchema Word32 where toNamedSchema = unnamed . paramSchemaToSchema
157+instance ToSchema Word32 where toSchemaDefinitions = plain . paramSchemaToSchema
133−instance ToSchema Word64 where toNamedSchema = unnamed . paramSchemaToSchema
158+instance ToSchema Word64 where toSchemaDefinitions = plain . paramSchemaToSchema
134−
159+
135−instance ToSchema Char where toNamedSchema = unnamed . paramSchemaToSchema
160+instance ToSchema Char where toSchemaDefinitions = plain . paramSchemaToSchema
136−instance ToSchema Scientific where toNamedSchema = unnamed . paramSchemaToSchema
161+instance ToSchema Scientific where toSchemaDefinitions = plain . paramSchemaToSchema
137−instance ToSchema Double where toNamedSchema = unnamed . paramSchemaToSchema
162+instance ToSchema Double where toSchemaDefinitions = plain . paramSchemaToSchema
138−instance ToSchema Float where toNamedSchema = unnamed . paramSchemaToSchema
163+instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
139
164
140instance ToSchema a => ToSchema (Maybe a) where
165instance ToSchema a => ToSchema (Maybe a) where
141− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
166+ toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
142
167
143instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
168instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
144
169
@@ -150,8 +175,8 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchem
150instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
175instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
151instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
176instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
152
177
153−timeNamedSchema :: String -> String -> NamedSchema
178+timeSchemaDefinitions :: String -> String -> (Definitions, NamedSchema)
154−timeNamedSchema name format = (Just name, mempty
179+timeSchemaDefinitions name format = pure (Just name, mempty
155 & schemaType .~ SwaggerString
180 & schemaType .~ SwaggerString
156 & schemaFormat ?~ T.pack format
181 & schemaFormat ?~ T.pack format
157 & schemaMinLength ?~ toInteger (length format))
182 & schemaMinLength ?~ toInteger (length format))
@@ -160,67 +185,67 @@ timeNamedSchema name format = (Just name, mempty
160-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
185-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
161-- Just "yyyy-mm-dd"
186-- Just "yyyy-mm-dd"
162instance ToSchema Day where
187instance ToSchema Day where
163− toNamedSchema _ = timeNamedSchema "Day" "yyyy-mm-dd"
188+ toSchemaDefinitions _ = timeSchemaDefinitions "Day" "yyyy-mm-dd"
164
189
165-- |
190-- |
166-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
191-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
167-- Just "yyyy-mm-ddThh:MM:ss"
192-- Just "yyyy-mm-ddThh:MM:ss"
168instance ToSchema LocalTime where
193instance ToSchema LocalTime where
169− toNamedSchema _ = timeNamedSchema "LocalTime" "yyyy-mm-ddThh:MM:ss"
194+ toSchemaDefinitions _ = timeSchemaDefinitions "LocalTime" "yyyy-mm-ddThh:MM:ss"
170
195
171-- |
196-- |
172-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
197-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
173-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
198-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
174instance ToSchema ZonedTime where
199instance ToSchema ZonedTime where
175− toNamedSchema _ = (Just "ZonedTime", mempty
200+ toSchemaDefinitions _ = pure (Just "ZonedTime", mempty
176 & schemaType .~ SwaggerString
201 & schemaType .~ SwaggerString
177 & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
202 & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
178 & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
203 & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
179
204
180instance ToSchema NominalDiffTime where
205instance ToSchema NominalDiffTime where
181− toNamedSchema _ = toNamedSchema (Proxy :: Proxy Integer)
206+ toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy Integer)
182
207
183-- |
208-- |
184-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
209-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
185-- Just "yyyy-mm-ddThh:MM:ssZ"
210-- Just "yyyy-mm-ddThh:MM:ssZ"
186instance ToSchema UTCTime where
211instance ToSchema UTCTime where
187− toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
212+ toSchemaDefinitions _ = timeSchemaDefinitions "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
188
213
189−instance ToSchema T.Text where toNamedSchema = unnamed . paramSchemaToSchema
214+instance ToSchema T.Text where toSchemaDefinitions = plain . paramSchemaToSchema
190−instance ToSchema TL.Text where toNamedSchema = unnamed . paramSchemaToSchema
215+instance ToSchema TL.Text where toSchemaDefinitions = plain . paramSchemaToSchema
191
216
192−instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int))
217+instance ToSchema IntSet where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set Int))
193
218
194-- | NOTE: This schema does not account for the uniqueness of keys.
219-- | NOTE: This schema does not account for the uniqueness of keys.
195instance ToSchema a => ToSchema (IntMap a) where
220instance ToSchema a => ToSchema (IntMap a) where
196− toNamedSchema _ = toNamedSchema (Proxy :: Proxy [(Int, a)])
221+ toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
197
222
198instance ToSchema a => ToSchema (Map String a) where
223instance ToSchema a => ToSchema (Map String a) where
199− toNamedSchema _ = unnamed $ mempty
224+ toSchemaDefinitions _ = plain $ mempty
200 & schemaType .~ SwaggerObject
225 & schemaType .~ SwaggerObject
201 & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
226 & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
202
227
203−instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
228+instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
204−instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
229+instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
205
230
206−instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
231+instance ToSchema a => ToSchema (HashMap String a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
207−instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
232+instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
208−instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
233+instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Map String a))
209
234
210instance ToSchema a => ToSchema (Set a) where
235instance ToSchema a => ToSchema (Set a) where
211− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
236+ toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy [a])
212 & schemaUniqueItems ?~ True
237 & schemaUniqueItems ?~ True
213
238
214−instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
239+instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy (Set a))
215
240
216−instance ToSchema All where toNamedSchema = unnamed . paramSchemaToSchema
241+instance ToSchema All where toSchemaDefinitions = plain . paramSchemaToSchema
217−instance ToSchema Any where toNamedSchema = unnamed . paramSchemaToSchema
242+instance ToSchema Any where toSchemaDefinitions = plain . paramSchemaToSchema
218
243
219−instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
244+instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
220−instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
245+instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
221−instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
246+instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
222−instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
247+instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
223−instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
248+instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = plain $ toSchema (Proxy :: Proxy a)
224
249
225-- | Default schema for @'Bounded'@, @'Integral'@ types.
250-- | Default schema for @'Bounded'@, @'Integral'@ types.
226toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
251toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
@@ -242,11 +267,15 @@ genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a ->
242genericToSchema opts = snd . genericToNamedSchema opts
267genericToSchema opts = snd . genericToNamedSchema opts
243
268
244-- | A configurable generic @'NamedSchema'@ creator.
269-- | A configurable generic @'NamedSchema'@ creator.
270+genericToNamedSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
271+genericToNamedSchema opts = snd . genericToSchemaDefinitions opts
272+
273+-- | A configurable generic @('NamedSchema', 'Definitions')@ creator.
245-- This function applied to @'defaultSchemaOptions'@
274-- This function applied to @'defaultSchemaOptions'@
246−-- is used as the default for @'toNamedSchema'@
275+-- is used as the default for @'toSchemaDefinitions'@
247-- when the type is an instance of @'Generic'@.
276-- when the type is an instance of @'Generic'@.
248−genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
277+genericToSchemaDefinitions :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> (Definitions, NamedSchema)
249−genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
278+genericToSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy (Rep a)) mempty
250
279
251gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
280gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
252gdatatypeSchemaName opts _ = case name of
281gdatatypeSchemaName opts _ = case name of
@@ -271,74 +300,86 @@ nullarySchema = mempty
271 & schemaEnum ?~ [ toJSON () ]
300 & schemaEnum ?~ [ toJSON () ]
272
301
273instance GToSchema U1 where
302instance GToSchema U1 where
274− gtoNamedSchema _ _ _ = unnamed nullarySchema
303+ gtoSchemaDefinitions _ _ _ = plain nullarySchema
275
304
276instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
305instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
277− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
306+ gtoSchemaDefinitions opts _ schema = (fdefs <> gdefs, unnamed fschema)
307+ where
308+ (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) gschema
309+ (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) schema
278
310
279instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
311instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
280− gtoNamedSchema opts _ s = (name, gtoSchema opts (Proxy :: Proxy f) s)
312+ gtoSchemaDefinitions opts _ s = (defs, (name, schema))
281 where
313 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
282 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
318 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
283
319
284instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
320instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
285− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f)
321+ gtoSchemaDefinitions opts _ s = (defs, unnamed schema)
322+ where
323+ (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
286
324
287-- | Single field constructor.
325-- | Single field constructor.
288instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
326instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
289− gtoNamedSchema opts _ s
327+ gtoSchemaDefinitions opts _ s
290− | unwrapUnaryRecords opts = fieldSchema
328+ | unwrapUnaryRecords opts = fieldSchemaDefs
291 | otherwise =
329 | otherwise =
292 case schema ^. schemaItems of
330 case schema ^. schemaItems of
293− Just (SchemaItemsArray [_]) -> fieldSchema
331+ Just (SchemaItemsArray [_]) -> fieldSchemaDefs
294− _ -> unnamed schema
332+ _ -> unname <$> schemaDefs
295 where
333 where
334+ (_, (_, schema)) = schemaDefs
296− schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
335+ schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) s
297− fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s
336+ fieldSchemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
298
337
299−gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
338+gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Referenced Schema)
300−gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
339+gtoSchemaRef opts proxy = case gtoSchemaDefinitions opts proxy mempty of
301− (Just name, _)
340+ (defs, (Just name, _))
302− | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name))
341+ | useReferences opts -> (defs, Ref (Reference ("#/definitions/" <> T.pack name)))
303− (_, schema) -> Inline schema
342+ (defs, (_, schema)) -> (defs, Inline schema)
304
343
305appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
344appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
306appendItem x Nothing = Just (SchemaItemsArray [x])
345appendItem x Nothing = Just (SchemaItemsArray [x])
307appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
346appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
308appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
347appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
309
348
310−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
349+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> (Definitions, Schema)
311−withFieldSchema opts _ isRequiredField schema
350+withFieldSchema opts _ isRequiredField schema = (defs, schema')
312− | T.null fieldName = schema
313− & schemaType .~ SwaggerArray
314− & schemaItems %~ appendItem fieldSchemaRef
315− | otherwise = schema
316− & schemaType .~ SwaggerObject
317− & schemaProperties . at fieldName ?~ fieldSchemaRef
318− & if isRequiredField
319− then schemaRequired %~ (fieldName :)
320− else id
321 where
351 where
352+ schema'
353+ | T.null fieldName = schema
354+ & schemaType .~ SwaggerArray
355+ & schemaItems %~ appendItem fieldSchemaRef
356+ | otherwise = schema
357+ & schemaType .~ SwaggerObject
358+ & schemaProperties . at fieldName ?~ fieldSchemaRef
359+ & if isRequiredField
360+ then schemaRequired %~ (fieldName :)
361+ else id
362+
322 fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
363 fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
323− fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
364+ (defs, fieldSchemaRef) = gtoSchemaRef opts (Proxy :: Proxy f)
324
365
325-- | Optional record fields.
366-- | Optional record fields.
326instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
367instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
327− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
368+ gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
328
369
329-- | Record fields.
370-- | Record fields.
330instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
371instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
331− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
372+ gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
332
373
333instance ToSchema c => GToSchema (K1 i c) where
374instance ToSchema c => GToSchema (K1 i c) where
334− gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
375+ gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
335
376
336instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
377instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
337− gtoNamedSchema opts _ s
378+ gtoSchemaDefinitions opts _ s
338− | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema)
379+ | allNullaryToStringTag opts && allNullary = plain (toStringTag sumSchema)
339− | otherwise = unnamed sumSchema
380+ | otherwise = (defs, unnamed sumSchema)
340 where
381 where
341− (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
382+ ((All allNullary, defs), sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
342
383
343 toStringTag schema = mempty
384 toStringTag schema = mempty
344 & schemaType .~ SwaggerString
385 & schemaType .~ SwaggerString
@@ -347,7 +388,7 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
347type AllNullary = All
388type AllNullary = All
348
389
349class GSumToSchema f where
390class GSumToSchema f where
350− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema)
391+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> ((AllNullary, Definitions), Schema)
351
392
352instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
393instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
353 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
394 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
@@ -358,8 +399,8 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
358 (b, s'') = g s'
399 (b, s'') = g s'
359
400
360gsumConToSchema :: forall c f proxy. Constructor c =>
401gsumConToSchema :: forall c f proxy. Constructor c =>
361− Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema)
402+ Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> Schema -> ((AllNullary, Definitions), Schema)
362−gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema
403+gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ schema = ((All isNullary, tagSchemaDefs), schema
363 & schemaType .~ SwaggerObject
404 & schemaType .~ SwaggerObject
364 & schemaProperties . at tag ?~ tagSchemaRef
405 & schemaProperties . at tag ?~ tagSchemaRef
365 & schemaMaxProperties ?~ 1
406 & schemaMaxProperties ?~ 1
src/Data/Swagger/Schema.hs+2
@@ -13,10 +13,12 @@ module Data.Swagger.Schema (
13 toSchema,
13 toSchema,
14 toSchemaRef,
14 toSchemaRef,
15 schemaName,
15 schemaName,
16+ independent,
16
17
17 -- * Generic schema encoding
18 -- * Generic schema encoding
18 genericToSchema,
19 genericToSchema,
19 genericToNamedSchema,
20 genericToNamedSchema,
21+ genericToSchemaDefinitions,
20 genericToNamedSchemaBoundedIntegral,
22 genericToNamedSchemaBoundedIntegral,
21 toSchemaBoundedIntegral,
23 toSchemaBoundedIntegral,
22 paramSchemaToNamedSchema,
24 paramSchemaToNamedSchema,
test/Data/Swagger/SchemaSpec.hs+9−7
@@ -105,7 +105,7 @@ data Point = Point
105 } deriving (Generic)
105 } deriving (Generic)
106
106
107instance ToSchema Point where
107instance ToSchema Point where
108− toNamedSchema = genericToNamedSchema defaultSchemaOptions
108+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
109 { fieldLabelModifier = map toLower . drop (length "point") }
109 { fieldLabelModifier = map toLower . drop (length "point") }
110
110
111pointSchemaJSON :: Value
111pointSchemaJSON :: Value
@@ -145,7 +145,7 @@ colorSchemaJSON = [aesonQQ|
145
145
146data Shade = Dim | Bright deriving (Generic, ToParamSchema)
146data Shade = Dim | Bright deriving (Generic, ToParamSchema)
147
147
148−instance ToSchema Shade where toNamedSchema = paramSchemaToNamedSchema defaultSchemaOptions
148+instance ToSchema Shade where toSchemaDefinitions = independent . paramSchemaToNamedSchema defaultSchemaOptions
149
149
150shadeSchemaJSON :: Value
150shadeSchemaJSON :: Value
151shadeSchemaJSON = [aesonQQ|
151shadeSchemaJSON = [aesonQQ|
@@ -185,7 +185,7 @@ newtype Email = Email { getEmail :: String }
185 deriving (Generic)
185 deriving (Generic)
186
186
187instance ToSchema Email where
187instance ToSchema Email where
188− toNamedSchema = genericToNamedSchema defaultSchemaOptions
188+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
189 { unwrapUnaryRecords = True }
189 { unwrapUnaryRecords = True }
190
190
191emailSchemaJSON :: Value
191emailSchemaJSON :: Value
@@ -258,7 +258,7 @@ data MyRoseTree = MyRoseTree
258 } deriving (Generic)
258 } deriving (Generic)
259
259
260instance ToSchema MyRoseTree where
260instance ToSchema MyRoseTree where
261− toNamedSchema = genericToNamedSchema defaultSchemaOptions
261+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
262 { datatypeNameModifier = drop (length "My") }
262 { datatypeNameModifier = drop (length "My") }
263
263
264myRoseTreeSchemaJSON :: Value
264myRoseTreeSchemaJSON :: Value
@@ -288,7 +288,9 @@ myRoseTreeSchemaJSON = [aesonQQ|
288newtype Inlined a = Inlined { getInlined :: a }
288newtype Inlined a = Inlined { getInlined :: a }
289
289
290instance ToSchema a => ToSchema (Inlined a) where
290instance ToSchema a => ToSchema (Inlined a) where
291− toNamedSchema _ = (Nothing, toSchema (Proxy :: Proxy a))
291+ toSchemaDefinitions _ = (defs, (Nothing, schema))
292+ where
293+ (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy a)
292
294
293newtype Players = Players [Inlined Player]
295newtype Players = Players [Inlined Player]
294 deriving (Generic, ToSchema)
296 deriving (Generic, ToSchema)
@@ -322,7 +324,7 @@ data Status
322 deriving (Generic)
324 deriving (Generic)
323
325
324instance ToSchema Status where
326instance ToSchema Status where
325− toNamedSchema = genericToNamedSchema defaultSchemaOptions
327+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
326 { constructorTagModifier = map toLower . drop (length "Status") }
328 { constructorTagModifier = map toLower . drop (length "Status") }
327
329
328statusSchemaJSON :: Value
330statusSchemaJSON :: Value
@@ -397,7 +399,7 @@ data Light
397 deriving (Generic)
399 deriving (Generic)
398
400
399instance ToSchema Light where
401instance ToSchema Light where
400− toNamedSchema = genericToNamedSchema defaultSchemaOptions
402+ toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
401 { unwrapUnaryRecords = True }
403 { unwrapUnaryRecords = True }
402
404
403lightSchemaJSON :: Value
405lightSchemaJSON :: Value