@@ -42,6 +42,7 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4242import Data.Int
4343import Data.IntSet (IntSet)
4444import Data.IntMap (IntMap)
45+import Data.List (sort)
4546import Data.List.NonEmpty.Compat (NonEmpty)
4647import Data.Map (Map)
4748import Data.Maybe (fromMaybe)
@@ -63,13 +64,14 @@ import GHC.Generics
6364import qualified Data.UUID.Types as UUID
6465import Type.Reflection (Typeable, typeRep)
6566
66−import Data.OpenApi.Declare
67−import Data.OpenApi.Internal
68−import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
69−import Data.OpenApi.Lens hiding (name, schema)
70−import qualified Data.OpenApi.Lens as Swagger
71−import Data.OpenApi.SchemaOptions
72−import Data.OpenApi.Internal.TypeShape
67+import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
68+import Data.OpenApi.Declare
69+import Data.OpenApi.Internal
70+import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71+import Data.OpenApi.Internal.TypeShape
72+import Data.OpenApi.Lens hiding (name, schema)
73+import qualified Data.OpenApi.Lens as Swagger
74+import Data.OpenApi.SchemaOptions
7375
7476import qualified Data.ByteString as BS
7577import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -134,7 +136,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
134136--
135137-- instance ToSchema Coord
136138-- @
137−class ToSchema a where
139+class Typeable a => ToSchema a where
138140 -- | Convert a type into an optionally named schema
139141 -- together with all used definitions.
140142 -- Note that the schema itself is included in definitions
@@ -156,13 +158,19 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
156158--
157159-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
158160-- Nothing
159−-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
160−-- {"type":"string"}
161+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy String) ^. schema)
162+-- {
163+-- "type": "string"
164+-- }
161165--
162166-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
163167-- Just "Day"
164−-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
165−-- {"example":"2016-07-22","format":"date","type":"string"}
168+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy Day) ^. schema)
169+-- {
170+-- "example": "2016-07-22",
171+-- "format": "date",
172+-- "type": "string"
173+-- }
166174toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
167175toNamedSchema = undeclare . declareNamedSchema
168176
@@ -178,22 +186,35 @@ schemaName = _namedSchemaName . toNamedSchema
178186
179187-- | Convert a type into a schema.
180188--
181−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8)
182−-- {"maximum":127,"minimum":-128,"type":"integer"}
189+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8)
190+-- {
191+-- "maximum": 127,
192+-- "minimum": -128,
193+-- "type": "integer"
194+-- }
183195--
184−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day])
185−-- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"}
196+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day])
197+-- {
198+-- "items": {
199+-- "$ref": "#/components/schemas/Day"
200+-- },
201+-- "type": "array"
202+-- }
186203toSchema :: ToSchema a => Proxy a -> Schema
187204toSchema = _namedSchemaSchema . toNamedSchema
188205
189206-- | Convert a type into a referenced schema if possible.
190207-- Only named schemas can be referenced, nameless schemas are inlined.
191208--
192−-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Integer)
193−-- {"type":"integer"}
209+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer)
210+-- {
211+-- "type": "integer"
212+-- }
194213--
195−-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day)
196−-- {"$ref":"#/components/schemas/Day"}
214+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day)
215+-- {
216+-- "$ref": "#/components/schemas/Day"
217+-- }
197218toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
198219toSchemaRef = undeclare . declareSchemaRef
199220
@@ -261,8 +282,15 @@ inlineAllSchemas = inlineSchemasWhen (const True)
261282
262283-- | Convert a type into a schema without references.
263284--
264−-- >>> BSL.putStrLn $ encode $ toInlinedSchema (Proxy :: Proxy [Day])
265−-- {"items":{"example":"2016-07-22","format":"date","type":"string"},"type":"array"}
285+-- >>> BSL.putStrLn $ encodePretty $ toInlinedSchema (Proxy :: Proxy [Day])
286+-- {
287+-- "items": {
288+-- "example": "2016-07-22",
289+-- "format": "date",
290+-- "type": "string"
291+-- },
292+-- "type": "array"
293+-- }
266294--
267295-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
268296-- when inlining recursive schemas.
@@ -295,19 +323,64 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
295323-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
296324-- Produced schema can be used for further refinement.
297325--
298−-- >>> BSL.putStrLn $ encode $ sketchSchema "hello"
299−-- {"example":"hello","type":"string"}
326+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema "hello"
327+-- {
328+-- "example": "hello",
329+-- "type": "string"
330+-- }
300331--
301−-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3)
302−-- {"example":[1,2,3],"items":{"type":"number"},"type":"array"}
332+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (1, 2, 3)
333+-- {
334+-- "example": [
335+-- 1,
336+-- 2,
337+-- 3
338+-- ],
339+-- "items": {
340+-- "type": "number"
341+-- },
342+-- "type": "array"
343+-- }
303344--
304−-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25)
305−-- {"example":["Jack",25],"items":[{"type":"string"},{"type":"number"}],"type":"array"}
345+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema ("Jack", 25)
346+-- {
347+-- "example": [
348+-- "Jack",
349+-- 25
350+-- ],
351+-- "items": [
352+-- {
353+-- "type": "string"
354+-- },
355+-- {
356+-- "type": "number"
357+-- }
358+-- ],
359+-- "type": "array"
360+-- }
306361--
307362-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
308363-- >>> instance ToJSON Person
309−-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25)
310−-- {"example":{"age":25,"name":"Jack"},"required":["age","name"],"type":"object","properties":{"age":{"type":"number"},"name":{"type":"string"}}}
364+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25)
365+-- {
366+-- "example": {
367+-- "age": 25,
368+-- "name": "Jack"
369+-- },
370+-- "properties": {
371+-- "age": {
372+-- "type": "number"
373+-- },
374+-- "name": {
375+-- "type": "string"
376+-- }
377+-- },
378+-- "required": [
379+-- "age",
380+-- "name"
381+-- ],
382+-- "type": "object"
383+-- }
311384sketchSchema :: ToJSON a => a -> Schema
312385sketchSchema = sketch . toJSON
313386 where
@@ -333,25 +406,139 @@ sketchSchema = sketch . toJSON
333406 _ -> Nothing
334407 go (Object o) = mempty
335408 & type_ ?~ OpenApiObject
336− & required .~ HashMap.keys o
337− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
409+ & required .~ sort (objectKeys o)
410+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
338411
339412-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
340413-- Produced schema uses as much constraints as possible.
341414--
342−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema "hello"
343−-- {"maxLength":5,"pattern":"hello","minLength":5,"type":"string","enum":["hello"]}
415+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema "hello"
416+-- {
417+-- "enum": [
418+-- "hello"
419+-- ],
420+-- "maxLength": 5,
421+-- "minLength": 5,
422+-- "pattern": "hello",
423+-- "type": "string"
424+-- }
344425--
345−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (1, 2, 3)
346−-- {"minItems":3,"uniqueItems":true,"items":[{"maximum":1,"minimum":1,"multipleOf":1,"type":"number","enum":[1]},{"maximum":2,"minimum":2,"multipleOf":2,"type":"number","enum":[2]},{"maximum":3,"minimum":3,"multipleOf":3,"type":"number","enum":[3]}],"maxItems":3,"type":"array","enum":[[1,2,3]]}
426+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (1, 2, 3)
427+-- {
428+-- "enum": [
429+-- [
430+-- 1,
431+-- 2,
432+-- 3
433+-- ]
434+-- ],
435+-- "items": [
436+-- {
437+-- "enum": [
438+-- 1
439+-- ],
440+-- "maximum": 1,
441+-- "minimum": 1,
442+-- "multipleOf": 1,
443+-- "type": "number"
444+-- },
445+-- {
446+-- "enum": [
447+-- 2
448+-- ],
449+-- "maximum": 2,
450+-- "minimum": 2,
451+-- "multipleOf": 2,
452+-- "type": "number"
453+-- },
454+-- {
455+-- "enum": [
456+-- 3
457+-- ],
458+-- "maximum": 3,
459+-- "minimum": 3,
460+-- "multipleOf": 3,
461+-- "type": "number"
462+-- }
463+-- ],
464+-- "maxItems": 3,
465+-- "minItems": 3,
466+-- "type": "array",
467+-- "uniqueItems": true
468+-- }
347469--
348−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema ("Jack", 25)
349−-- {"minItems":2,"uniqueItems":true,"items":[{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]},{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]}],"maxItems":2,"type":"array","enum":[["Jack",25]]}
470+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema ("Jack", 25)
471+-- {
472+-- "enum": [
473+-- [
474+-- "Jack",
475+-- 25
476+-- ]
477+-- ],
478+-- "items": [
479+-- {
480+-- "enum": [
481+-- "Jack"
482+-- ],
483+-- "maxLength": 4,
484+-- "minLength": 4,
485+-- "pattern": "Jack",
486+-- "type": "string"
487+-- },
488+-- {
489+-- "enum": [
490+-- 25
491+-- ],
492+-- "maximum": 25,
493+-- "minimum": 25,
494+-- "multipleOf": 25,
495+-- "type": "number"
496+-- }
497+-- ],
498+-- "maxItems": 2,
499+-- "minItems": 2,
500+-- "type": "array",
501+-- "uniqueItems": true
502+-- }
350503--
351504-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
352505-- >>> instance ToJSON Person
353−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25)
354−-- {"minProperties":2,"required":["age","name"],"maxProperties":2,"type":"object","enum":[{"age":25,"name":"Jack"}],"properties":{"age":{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]},"name":{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]}}}
506+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25)
507+-- {
508+-- "enum": [
509+-- {
510+-- "age": 25,
511+-- "name": "Jack"
512+-- }
513+-- ],
514+-- "maxProperties": 2,
515+-- "minProperties": 2,
516+-- "properties": {
517+-- "age": {
518+-- "enum": [
519+-- 25
520+-- ],
521+-- "maximum": 25,
522+-- "minimum": 25,
523+-- "multipleOf": 25,
524+-- "type": "number"
525+-- },
526+-- "name": {
527+-- "enum": [
528+-- "Jack"
529+-- ],
530+-- "maxLength": 4,
531+-- "minLength": 4,
532+-- "pattern": "Jack",
533+-- "type": "string"
534+-- }
535+-- },
536+-- "required": [
537+-- "age",
538+-- "name"
539+-- ],
540+-- "type": "object"
541+-- }
355542sketchStrictSchema :: ToJSON a => a -> Schema
356543sketchStrictSchema = go . toJSON
357544 where
@@ -383,13 +570,13 @@ sketchStrictSchema = go . toJSON
383570 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
384571 go js@(Object o) = mempty
385572 & type_ ?~ OpenApiObject
386− & required .~ names
387− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
573+ & required .~ sort names
574+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
388575 & maxProperties ?~ fromIntegral (length names)
389576 & minProperties ?~ fromIntegral (length names)
390577 & enum_ ?~ [js]
391578 where
392− names = HashMap.keys o
579+ names = objectKeys o
393580
394581class GToSchema (f :: * -> *) where
395582 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -424,7 +611,7 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
424611instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
425612instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
426613
427−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
614+instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
428615
429616instance ToSchema a => ToSchema (Maybe a) where
430617 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -441,12 +628,18 @@ instance ToSchema UUID.UUID where
441628 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
442629 & example ?~ toJSON (UUID.toText UUID.nil)
443630
444−instance (ToSchema a, ToSchema b) => ToSchema (a, b)
445−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
446−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
447−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
448−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
449−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
631+instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
632+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
633+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
634+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
635+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
636+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
637+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
638+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
639+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
640+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
641+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
642+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
450643
451644timeSchema :: T.Text -> Schema
452645timeSchema fmt = mempty
@@ -465,7 +658,7 @@ instance ToSchema LocalTime where
465658 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
466659 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
467660
468−-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
661+-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
469662instance ToSchema ZonedTime where
470663 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
471664 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -497,7 +690,7 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
497690instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
498691
499692-- | NOTE: This schema does not account for the uniqueness of keys.
500−instance ToSchema a => ToSchema (IntMap a) where
693+instance (ToSchema a) => ToSchema (IntMap a) where
501694 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
502695
503696instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
@@ -553,8 +746,12 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
553746
554747-- | Default schema for @'Bounded'@, @'Integral'@ types.
555748--
556−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
557−-- {"maximum":32767,"minimum":-32768,"type":"integer"}
749+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
750+-- {
751+-- "maximum": 32767,
752+-- "minimum": -32768,
753+-- "type": "integer"
754+-- }
558755toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
559756toSchemaBoundedIntegral _ = mempty
560757 & type_ ?~ OpenApiInteger
@@ -586,8 +783,27 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>
586783-- >>> instance ToSchema ButtonState
587784-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
588785-- >>> type ImageUrl = T.Text
589−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
590−-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
786+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
787+-- {
788+-- "properties": {
789+-- "Active": {
790+-- "type": "string"
791+-- },
792+-- "Disabled": {
793+-- "type": "string"
794+-- },
795+-- "Focus": {
796+-- "type": "string"
797+-- },
798+-- "Hover": {
799+-- "type": "string"
800+-- },
801+-- "Neutral": {
802+-- "type": "string"
803+-- }
804+-- },
805+-- "type": "object"
806+-- }
591807--
592808-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
593809-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
@@ -595,13 +811,13 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.
595811 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
596812 => Proxy (map key value) -> Declare (Definitions Schema) Schema
597813declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
598− ToJSONKeyText keyToText _ -> objectSchema keyToText
814+ ToJSONKeyText getKey _ -> objectSchema getKey
599815 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
600816 where
601− objectSchema keyToText = do
817+ objectSchema getKey = do
602818 valueRef <- declareSchemaRef (Proxy :: Proxy value)
603819 let allKeys = [minBound..maxBound :: key]
604− mkPair k = (keyToText k, valueRef)
820+ mkPair k = (keyToText $ getKey k, valueRef)
605821 return $ mempty
606822 & type_ ?~ OpenApiObject
607823 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
@@ -614,8 +830,27 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
614830-- >>> instance ToSchema ButtonState
615831-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
616832-- >>> type ImageUrl = T.Text
617−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
618−-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
833+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
834+-- {
835+-- "properties": {
836+-- "Active": {
837+-- "type": "string"
838+-- },
839+-- "Disabled": {
840+-- "type": "string"
841+-- },
842+-- "Focus": {
843+-- "type": "string"
844+-- },
845+-- "Hover": {
846+-- "type": "string"
847+-- },
848+-- "Neutral": {
849+-- "type": "string"
850+-- }
851+-- },
852+-- "type": "object"
853+-- }
619854--
620855-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
621856-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
@@ -625,7 +860,7 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
625860toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
626861
627862-- | A configurable generic @'Schema'@ creator.
628−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
863+genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
629864 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
630865genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
631866
@@ -633,9 +868,24 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
633868-- This function applied to @'defaultSchemaOptions'@
634869-- is used as the default for @'declareNamedSchema'@
635870-- when the type is an instance of @'Generic'@.
636−genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
871+--
872+-- Default implementation will use the name from 'Typeable' instance, including concrete
873+-- instantioations of type variables.
874+--
875+-- For example:
876+--
877+-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878+-- Just "Either_Int_Bool"
879+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
637880 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
638−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
881+genericDeclareNamedSchema opts _ =
882+ rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
883+ where
884+ unspace ' ' = '_'
885+ unspace x = x
886+ orig = fmap unspace $ show $ typeRep @a
887+ name = datatypeNameModifier opts orig
888+
639889
640890-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
641891genericNameSchema :: forall a d f.
@@ -695,10 +945,13 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
695945 case schema ^. items of
696946 Just (OpenApiItemsArray [_]) -> fieldSchema
697947 _ -> do
698− declare defs
699− return (unnamed schema)
948+ -- We have to run recordSchema instead of just using its defs,
949+ -- since those can be recursive and will lead to infinite loop,
950+ -- see https://github.com/biocad/openapi3/pull/37
951+ NamedSchema _ schema' <- recordSchema
952+ return (unnamed schema')
700953 where
701− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
954+ (_, NamedSchema _ schema) = runDeclare recordSchema mempty
702955 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
703956 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
704957
@@ -861,58 +1114,13 @@ data Proxy2 a b = Proxy2
8611114
8621115data Proxy3 a b c = Proxy3
8631116
864−-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
865−--
866−-- Intended usage:
867−--
868−-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
869−-- >>> :{
870−-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
871−-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
872−-- :}
873−--
874−-- >>> toNamedSchema @(Foo Int) Proxy ^. name
875−-- Just "Foo_Int"
876−-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
877−-- Just "Foo_Bool"
878−-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
879−-- Just "Foo_(Foo_Text)"
880−class ToSchema1 (f :: * -> *) where
881− declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
882−
883− -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
884− -- above, however sadly GHC does not like it.
885− default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
886− declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
887−
888−{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
889−using 'ToSchema1' instance, like this:
890−
891−#if __GLASGOW_HASKELL__ >= 806
892−>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
893−>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
894−#else
895−> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
896−> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
897−#endif
898−-}
899−newtype BySchema1 f a = BySchema1 (f a)
900−
901−instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
902− declareNamedSchema _ = do
903− sch <- declareNamedSchema1 @f @a Proxy Proxy
904− let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
905− return $ rename (Just tName) sch
906−
9071117{- $setup
9081118>>> import Data.OpenApi
9091119>>> import Data.Aeson (encode)
9101120>>> import Data.Aeson.Types (toJSONKeyText)
1121+>>> import Data.OpenApi.Internal.Utils
9111122>>> :set -XScopedTypeVariables
9121123>>> :set -XDeriveAnyClass
9131124>>> :set -XStandaloneDeriving
9141125>>> :set -XTypeApplications
915−#if __GLASGOW_HASKELL__ >= 806
916−>>> :set -XDerivingVia
917−#endif
9181126-}