@@ -14,6 +14,8 @@
14module Data.Swagger.Internal.Schema where
14module Data.Swagger.Internal.Schema where
16import Control.Lens
16import Control.Lens
18+import Control.Monad.Writer
17import Data.Aeson
19import Data.Aeson
18import Data.Char
20import Data.Char
19import Data.HashMap.Strict (HashMap)
21import Data.HashMap.Strict (HashMap)
@@ -33,6 +35,7 @@ import Data.Time
33import Data.Word
35import Data.Word
34import GHC.Generics
36import GHC.Generics
38+import Data.Swagger.Declare
36import Data.Swagger.Internal
39import Data.Swagger.Internal
37import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
40import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
38import Data.Swagger.Lens
41import Data.Swagger.Lens
@@ -51,12 +54,15 @@ unnamed schema = (Nothing, schema)
51named :: String -> Schema -> NamedSchema
54named :: String -> Schema -> NamedSchema
52named name schema = (Just name, schema)
55named name schema = (Just name, schema)
54−plain :: Schema -> (Definitions, NamedSchema)
57+plain :: Schema -> Declare Definitions NamedSchema
55−plain schema = (mempty, unnamed schema)
58+plain = pure . unnamed
57unname :: NamedSchema -> NamedSchema
60unname :: NamedSchema -> NamedSchema
58unname (_, schema) = (Nothing, schema)
61unname (_, schema) = (Nothing, schema)
63+rename :: Maybe String -> NamedSchema -> NamedSchema
64+rename name (_, schema) = (name, schema)
60-- | Convert a type into @'Schema'@.
66-- | Convert a type into @'Schema'@.
62-- An example type and instance:
68-- An example type and instance:
@@ -104,13 +110,13 @@ class ToSchema a where
104 -- together with all used definitions.
110 -- together with all used definitions.
105 -- Note that the schema itself is included in definitions
111 -- Note that the schema itself is included in definitions
106 -- only if it is recursive (and thus needs its definition in scope).
112 -- only if it is recursive (and thus needs its definition in scope).
107− toSchemaDefinitions :: proxy a -> (Definitions, NamedSchema)
113+ toSchemaDefinitions :: proxy a -> Declare Definitions NamedSchema
108− default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> (Definitions, NamedSchema)
114+ default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare Definitions NamedSchema
109 toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
115 toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
111-- | Convert a type into an optionally named schema.
117-- | Convert a type into an optionally named schema.
112toNamedSchema :: ToSchema a => proxy a -> NamedSchema
118toNamedSchema :: ToSchema a => proxy a -> NamedSchema
113−toNamedSchema = snd . toSchemaDefinitions
119+toNamedSchema = undeclare . toSchemaDefinitions
115-- | Get type's schema name according to its @'ToSchema'@ instance.
121-- | Get type's schema name according to its @'ToSchema'@ instance.
116schemaName :: ToSchema a => proxy a -> Maybe String
122schemaName :: ToSchema a => proxy a -> Maybe String
@@ -120,30 +126,34 @@ schemaName = fst . toNamedSchema
120toSchema :: ToSchema a => proxy a -> Schema
126toSchema :: ToSchema a => proxy a -> Schema
121toSchema = snd . toNamedSchema
127toSchema = snd . toNamedSchema
129+declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema
130+declareSchema = fmap snd . toSchemaDefinitions
123-- | Convert a type into a referenced schema if possible.
132-- | Convert a type into a referenced schema if possible.
124-- Only named schemas can be references, nameless schemas are inlined.
133-- Only named schemas can be references, nameless schemas are inlined.
125toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
134toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
135+toSchemaRef = undeclare . declareSchemaRef
137+declareSchemaRef :: ToSchema a => proxy a -> Declare Definitions (Referenced Schema)
138+declareSchemaRef proxy = do
126−toSchemaRef proxy = case toNamedSchema proxy of
139+ case toNamedSchema proxy of
140+ (Just name, schema) -> do
141+ known <- looks (HashMap.member (T.pack name))
142+ when (not known) $ do
143+ declare [(T.pack name, schema)]
144+ void $ toSchemaDefinitions proxy
127− (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
145+ return $ Ref (Reference ("#/definitions/" <> T.pack name))
128− (_, schema) -> Inline schema
146+ _ -> Inline <$> declareSchema proxy
130class GToSchema (f :: * -> *) where
148class GToSchema (f :: * -> *) where
131− gtoSchemaDefinitions :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (Definitions, NamedSchema)
149+ gtoSchemaDefinitions :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema
133−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> NamedSchema
134−gtoNamedSchema opts proxy = snd . gtoSchemaDefinitions opts proxy
136−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Schema) -> Schema
137−gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
139instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
151instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
140− toSchemaDefinitions _ = (defs, unnamed schema)
152+ toSchemaDefinitions _ = do
141− where
153+ ref <- declareSchemaRef (Proxy :: Proxy a)
142− schema = mempty
154+ return $ unnamed $ mempty
143− & schemaType .~ SwaggerArray
155+ & schemaType .~ SwaggerArray
144− & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
156+ & schemaItems ?~ SchemaItemsObject ref
146− (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
148instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
158instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
149instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
159instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
@@ -165,9 +175,7 @@ instance ToSchema Double where toSchemaDefinitions = plain . paramSchemaToS
165instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
175instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
167instance ToSchema a => ToSchema (Maybe a) where
177instance ToSchema a => ToSchema (Maybe a) where
168− toSchemaDefinitions _ = (defs, unnamed schema)
170− (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy a)
178+ toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy a)
172instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
180instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
@@ -179,32 +187,30 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchem
179instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
187instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
180instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
188instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
182−timeSchemaDefinitions :: String -> String -> (Definitions, NamedSchema)
190+timeSchema :: String -> Schema
183−timeSchemaDefinitions name format = pure (Just name, mempty
191+timeSchema format = mempty
184 & schemaType .~ SwaggerString
192 & schemaType .~ SwaggerString
185 & schemaFormat ?~ T.pack format
193 & schemaFormat ?~ T.pack format
186− & schemaMinLength ?~ toInteger (length format))
194+ & schemaMinLength ?~ toInteger (length format)
189-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
197-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
190-- Just "yyyy-mm-dd"
198-- Just "yyyy-mm-dd"
191instance ToSchema Day where
199instance ToSchema Day where
192− toSchemaDefinitions _ = timeSchemaDefinitions "Day" "yyyy-mm-dd"
200+ toSchemaDefinitions _ = pure $ named "Day" (timeSchema "yyyy-mm-dd")
195-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
203-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
196-- Just "yyyy-mm-ddThh:MM:ss"
204-- Just "yyyy-mm-ddThh:MM:ss"
197instance ToSchema LocalTime where
205instance ToSchema LocalTime where
198− toSchemaDefinitions _ = timeSchemaDefinitions "LocalTime" "yyyy-mm-ddThh:MM:ss"
206+ toSchemaDefinitions _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
201-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
209-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
202-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
210-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
203instance ToSchema ZonedTime where
211instance ToSchema ZonedTime where
204− toSchemaDefinitions _ = pure (Just "ZonedTime", mempty
212+ toSchemaDefinitions _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
205− & schemaType .~ SwaggerString
206− & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
207− & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
213+ & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String))
209instance ToSchema NominalDiffTime where
215instance ToSchema NominalDiffTime where
210 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy Integer)
216 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy Integer)
@@ -213,7 +219,7 @@ instance ToSchema NominalDiffTime where
213-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
219-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
214-- Just "yyyy-mm-ddThh:MM:ssZ"
220-- Just "yyyy-mm-ddThh:MM:ssZ"
215instance ToSchema UTCTime where
221instance ToSchema UTCTime where
216− toSchemaDefinitions _ = timeSchemaDefinitions "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
222+ toSchemaDefinitions _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
218instance ToSchema T.Text where toSchemaDefinitions = plain . paramSchemaToSchema
224instance ToSchema T.Text where toSchemaDefinitions = plain . paramSchemaToSchema
219instance ToSchema TL.Text where toSchemaDefinitions = plain . paramSchemaToSchema
225instance ToSchema TL.Text where toSchemaDefinitions = plain . paramSchemaToSchema
@@ -225,13 +231,11 @@ instance ToSchema a => ToSchema (IntMap a) where
225 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
231 toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
227instance ToSchema a => ToSchema (Map String a) where
233instance ToSchema a => ToSchema (Map String a) where
228− toSchemaDefinitions _ = (defs, unnamed schema)
234+ toSchemaDefinitions _ = do
229− where
235+ schema <- declareSchema (Proxy :: Proxy a)
230− schema = mempty
236+ return $ unnamed $ mempty
231− & schemaType .~ SwaggerObject
237+ & schemaType .~ SwaggerObject
232− & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
238+ & schemaAdditionalProperties ?~ schema
234− (defs, _) = toSchemaDefinitions (Proxy :: Proxy a)
236instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
240instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
237instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
241instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
@@ -241,9 +245,10 @@ instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _
241instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
245instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
243instance ToSchema a => ToSchema (Set a) where
247instance ToSchema a => ToSchema (Set a) where
248+ toSchemaDefinitions _ = do
249+ schema <- declareSchema (Proxy :: Proxy [a])
250+ return $ unnamed $ schema
244− toSchemaDefinitions _ = (defs, unnamed (schema & schemaUniqueItems ?~ True))
251+ & schemaUniqueItems ?~ True
246− (defs, (_, schema)) = toSchemaDefinitions (Proxy :: Proxy [a])
248instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set a))
253instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set a))
@@ -277,13 +282,13 @@ genericToSchema opts = snd . genericToNamedSchema opts
278-- | A configurable generic @'NamedSchema'@ creator.
283-- | A configurable generic @'NamedSchema'@ creator.
279genericToNamedSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
284genericToNamedSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
280−genericToNamedSchema opts = snd . genericToSchemaDefinitions opts
285+genericToNamedSchema opts = undeclare . genericToSchemaDefinitions opts
282−-- | A configurable generic @('NamedSchema', 'Definitions')@ creator.
287+-- | A configurable generic @'NamedSchema'@ creator with declarations.
283-- This function applied to @'defaultSchemaOptions'@
288-- This function applied to @'defaultSchemaOptions'@
284-- is used as the default for @'toSchemaDefinitions'@
289-- is used as the default for @'toSchemaDefinitions'@
285-- when the type is an instance of @'Generic'@.
290-- when the type is an instance of @'Generic'@.
286−genericToSchemaDefinitions :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> (Definitions, NamedSchema)
291+genericToSchemaDefinitions :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema
287genericToSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy (Rep a)) mempty
292genericToSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy (Rep a)) mempty
289gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
294gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
@@ -308,44 +313,57 @@ nullarySchema = mempty
308 & schemaType .~ SwaggerArray
313 & schemaType .~ SwaggerArray
309 & schemaEnum ?~ [ toJSON () ]
314 & schemaEnum ?~ [ toJSON () ]
316+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
317+gtoNamedSchema opts proxy = undeclare $ gtoSchemaDefinitions opts proxy mempty
319+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema
320+gtoSchema opts = snd . gtoNamedSchema opts
322+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema
323+gdeclareSchema opts proxy = snd <$> gtoSchemaDefinitions opts proxy mempty
325+gschemaName :: GToSchema f => SchemaOptions -> proxy f -> Maybe String
326+gschemaName opts = fst . gtoNamedSchema opts
311instance GToSchema U1 where
328instance GToSchema U1 where
312 gtoSchemaDefinitions _ _ _ = plain nullarySchema
329 gtoSchemaDefinitions _ _ _ = plain nullarySchema
314instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
331instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
315− gtoSchemaDefinitions opts _ (defs, schema) = (fdefs, unnamed fschema)
332+ gtoSchemaDefinitions opts _ schema = do
317− (fdefs, (_, fschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (gdefs, gschema)
318− (gdefs, (_, gschema)) = gtoSchemaDefinitions opts (Proxy :: Proxy g) (defs, schema)
333+ (_, gschema) <- gtoSchemaDefinitions opts (Proxy :: Proxy g) schema
334+ gtoSchemaDefinitions opts (Proxy :: Proxy f) gschema
320instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
336instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
321− gtoSchemaDefinitions opts _ (ds, s) = (schemaDefs, (name, schema))
337+ gtoSchemaDefinitions opts _ s = rename name <$> gtoSchemaDefinitions opts (Proxy :: Proxy f) s
323− (schemaDefs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
324 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
339 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
326instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
341instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
327− gtoSchemaDefinitions opts _ (ds, s) = (defs, unnamed schema)
329− (defs, (_, schema)) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
342+ gtoSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy f)
331-- | Single field constructor.
344-- | Single field constructor.
332instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
345instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
333− gtoSchemaDefinitions opts _ (ds, s)
346+ gtoSchemaDefinitions opts _ s
334− | unwrapUnaryRecords opts = (fieldDefs, fieldNamedSchema)
347+ | unwrapUnaryRecords opts = fieldSchema
335− | otherwise =
348+ | otherwise = do
349+ (_, schema) <- recordSchema
336 case schema ^. schemaItems of
350 case schema ^. schemaItems of
337− Just (SchemaItemsArray [_]) -> (fieldDefs, fieldNamedSchema)
351+ Just (SchemaItemsArray [_]) -> fieldSchema
338− _ -> (defs, unnamed schema)
352+ _ -> pure (unnamed schema)
340− (defs, (_, schema)) = schemaDefs
341− schemaDefs = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) (ds, s)
354+ recordSchema = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) s
342− (fieldDefs, fieldNamedSchema) = gtoSchemaDefinitions opts (Proxy :: Proxy f) (ds, s)
355+ fieldSchema = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
344−gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> (Definitions, Referenced Schema)
357+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare Definitions (Referenced Schema)
345−gtoSchemaRef opts proxy = case gtoSchemaDefinitions opts proxy mempty of
358+gdeclareSchemaRef opts proxy = do
359+ case gtoNamedSchema opts proxy of
346− (defs, (Just name, _))
360+ (Just name, schema) -> do
361+ known <- looks (HashMap.member (T.pack name))
362+ when (not known) $ do
363+ declare [(T.pack name, schema)]
364+ void $ gtoSchemaDefinitions opts proxy mempty
347− | useReferences opts -> (defs, Ref (Reference ("#/definitions/" <> T.pack name)))
365+ return $ Ref (Reference ("#/definitions/" <> T.pack name))
348− (defs, (_, schema)) -> (defs, Inline schema)
366+ _ -> Inline <$> gdeclareSchema opts proxy
350appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
368appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
351appendItem x Nothing = Just (SchemaItemsArray [x])
369appendItem x Nothing = Just (SchemaItemsArray [x])
@@ -353,22 +371,22 @@ appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
353appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
371appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
355withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
373withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
356− SchemaOptions -> proxy s f -> Bool -> (Definitions, Schema) -> (Definitions, Schema)
374+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema
357−withFieldSchema opts _ isRequiredField (ds, schema) = (ds <> defs, schema')
375+withFieldSchema opts _ isRequiredField schema = do
376+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
380+ & schemaType .~ SwaggerArray
381+ & schemaItems %~ appendItem ref
383+ & schemaType .~ SwaggerObject
384+ & schemaProperties . at fname ?~ ref
385+ & if isRequiredField
386+ then schemaRequired %~ (fname :)
360− | T.null fieldName = schema
361− & schemaType .~ SwaggerArray
362− & schemaItems %~ appendItem fieldSchemaRef
363− | otherwise = schema
364− & schemaType .~ SwaggerObject
365− & schemaProperties . at fieldName ?~ fieldSchemaRef
366− & if isRequiredField
367− then schemaRequired %~ (fieldName :)
370− fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
389+ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
371− (defs, fieldSchemaRef) = gtoSchemaRef opts (Proxy :: Proxy f)
373-- | Optional record fields.
391-- | Optional record fields.
374instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
392instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
@@ -378,22 +396,19 @@ instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (
378instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
396instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
379 gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
397 gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
381−instance ToSchema c => GToSchema (K1 i c) where
399+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
382− gtoSchemaDefinitions _ _ (ds, _)
400+ gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
383− | present = (ds, (name, schema))
401+
384− | otherwise = (ds <> defs <> def, (name, schema))
402+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) 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)
403+ gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
391instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
405instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
392− gtoSchemaDefinitions opts _ (ds, s)
406+ gtoSchemaDefinitions opts _ s
393− | allNullaryToStringTag opts && allNullary = (ds, unnamed (toStringTag sumSchema))
407+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
394− | otherwise = (ds <> defs, unnamed sumSchema)
408+ | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
396− (All allNullary, (defs, sumSchema)) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) (ds, s)
410+ declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
411+ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
398 toStringTag schema = mempty
413 toStringTag schema = mempty
399 & schemaType .~ SwaggerString
414 & schemaType .~ SwaggerString
@@ -402,40 +417,35 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
402type AllNullary = All
417type AllNullary = All
404class GSumToSchema f where
419class GSumToSchema f where
405− gsumToSchema :: SchemaOptions -> proxy f -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
420+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema
407instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
422instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
408− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
423+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
410− (f `after` g) s = (a <> b, s'')
415−gsumConToSchema :: forall c f proxy. Constructor c =>
425+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
416− Bool -> (Definitions, Referenced Schema) -> SchemaOptions -> proxy (C1 c f) -> (Definitions, Schema) -> (AllNullary, (Definitions, Schema))
426+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare Definitions Schema
417−gsumConToSchema isNullary (tagSchemaDefs, tagSchemaRef) opts _ (defs, schema) = (All isNullary, (defs <> tagSchemaDefs, schema
427+gsumConToSchema opts _ schema = do
428+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f))
418− & schemaType .~ SwaggerObject
430+ & schemaType .~ SwaggerObject
419− & schemaProperties . at tag ?~ tagSchemaRef
431+ & schemaProperties . at tag ?~ ref
420− & schemaMaxProperties ?~ 1
432+ & schemaMaxProperties ?~ 1
421− & schemaMinProperties ?~ 1))
433+ & schemaMinProperties ?~ 1
423 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
435 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
425instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
437instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
426− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
438+ gsumToSchema opts proxy schema = do
427− where
439+ tell (All False)
428− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f))
440+ lift $ gsumConToSchema opts proxy schema
430−instance Constructor c => GSumToSchema (C1 c U1) where
431− gsumToSchema opts = gsumConToSchema True tagSchemaRef opts
433− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1))
435instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
442instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
436− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
443+ gsumToSchema opts proxy schema = do
437− where
444+ tell (All False)
438− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f)))
445+ lift $ gsumConToSchema opts proxy schema
447+instance Constructor c => GSumToSchema (C1 c U1) where
448+ gsumToSchema opts proxy = lift . gsumConToSchema opts proxy
440data Proxy2 a b = Proxy2
450data Proxy2 a b = Proxy2