@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DefaultSignatures #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
@@ -13,6 +14,13 @@
1314{-# LANGUAGE TypeFamilies #-}
1415{-# LANGUAGE TypeOperators #-}
1516{-# LANGUAGE TypeSynonymInstances #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ >= 800
19+-- Few generics related redundant constraints
20+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
21+-- For TypeErrors
22+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
23+#endif
1624#include "overlapping-compat.h"
1725module Data.Swagger.Internal.Schema where
1826
@@ -22,27 +30,25 @@ import Prelude.Compat
2230import Control.Lens
2331import Data.Data.Lens (template)
2432
25−import Control.Applicative
2633import Control.Monad
2734import Control.Monad.Writer
28−import Data.Aeson
29−import qualified Data.Aeson.Types as Aeson
35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
3036import Data.Char
3137import Data.Data (Data)
3238import Data.Foldable (traverse_)
33−import Data.Function (on)
3439import Data.HashMap.Strict (HashMap)
3540import qualified Data.HashMap.Strict as HashMap
3641import "unordered-containers" Data.HashSet (HashSet)
3742import qualified "unordered-containers" Data.HashSet as HashSet
38−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
3943import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4044import Data.Int
4145import Data.IntSet (IntSet)
4246import Data.IntMap (IntMap)
47+import Data.List.NonEmpty.Compat (NonEmpty)
4348import Data.Map (Map)
4449import Data.Proxy
4550import Data.Scientific (Scientific)
51+import Data.Fixed (Fixed, HasResolution, Pico)
4652import Data.Set (Set)
4753import qualified Data.Text as T
4854import qualified Data.Text.Lazy as TL
@@ -51,6 +57,8 @@ import qualified Data.Vector as V
5157import qualified Data.Vector.Primitive as VP
5258import qualified Data.Vector.Storable as VS
5359import qualified Data.Vector.Unboxed as VU
60+import Data.Version (Version)
61+import Numeric.Natural.Compat (Natural)
5462import Data.Word
5563import GHC.Generics
5664import qualified Data.UUID.Types as UUID
@@ -61,9 +69,13 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
6169import Data.Swagger.Lens hiding (name, schema)
6270import qualified Data.Swagger.Lens as Swagger
6371import Data.Swagger.SchemaOptions
72+import Data.Swagger.Internal.TypeShape
6473
65−#ifdef __DOCTEST__
66−import Data.Swagger.Lens (name, schema)
74+#if __GLASGOW_HASKELL__ < 800
75+#else
76+import qualified Data.ByteString as BS
77+import qualified Data.ByteString.Lazy as BSL
78+import GHC.TypeLits (TypeError, ErrorMessage(..))
6779#endif
6880
6981unnamed :: Schema -> NamedSchema
@@ -90,14 +102,16 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
90102-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
91103--
92104-- import Control.Lens
105+-- import Data.Proxy
106+-- import Data.Swagger
93107--
94108-- data Coord = Coord { x :: Double, y :: Double }
95109--
96110-- instance ToSchema Coord where
97−-- declareNamedSchema = do
111+-- declareNamedSchema _ = do
98112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
99−-- return $ NamedSchema (Just \"Coord\")) $ mempty
100−-- & type_ .~ SwaggerObject
113+-- return $ NamedSchema (Just \"Coord\") $ mempty
114+-- & type_ ?~ SwaggerObject
101115-- & properties .~
102116-- [ (\"x\", doubleSchema)
103117-- , (\"y\", doubleSchema)
@@ -128,12 +142,17 @@ class ToSchema a where
128142 -- together with all used definitions.
129143 -- Note that the schema itself is included in definitions
130144 -- only if it is recursive (and thus needs its definition in scope).
131− declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
132− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
145+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147+ Proxy a -> Declare (Definitions Schema) NamedSchema
133148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
134149
150+instance ToSchema TimeOfDay where
151+ declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152+ & example ?~ toJSON (TimeOfDay 12 33 15)
153+
135154-- | Convert a type into a schema and declare all used schema definitions.
136−declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
155+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
137156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
138157
139158-- | Convert a type into an optionally named schema.
@@ -147,7 +166,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
147166-- Just "Day"
148167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
149168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
150−toNamedSchema :: ToSchema a => proxy a -> NamedSchema
169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
151170toNamedSchema = undeclare . declareNamedSchema
152171
153172-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -157,7 +176,7 @@ toNamedSchema = undeclare . declareNamedSchema
157176--
158177-- >>> schemaName (Proxy :: Proxy UTCTime)
159178-- Just "UTCTime"
160−schemaName :: ToSchema a => proxy a -> Maybe T.Text
179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text
161180schemaName = _namedSchemaName . toNamedSchema
162181
163182-- | Convert a type into a schema.
@@ -167,7 +186,7 @@ schemaName = _namedSchemaName . toNamedSchema
167186--
168187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
169188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
170−toSchema :: ToSchema a => proxy a -> Schema
189+toSchema :: ToSchema a => Proxy a -> Schema
171190toSchema = _namedSchemaSchema . toNamedSchema
172191
173192-- | Convert a type into a referenced schema if possible.
@@ -178,7 +197,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
178197--
179198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
180199-- "{\"$ref\":\"#/definitions/Day\"}"
181−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
182201toSchemaRef = undeclare . declareSchemaRef
183202
184203-- | Convert a type into a referenced schema if possible
@@ -188,7 +207,7 @@ toSchemaRef = undeclare . declareSchemaRef
188207-- Schema definitions are typically declared for every referenced schema.
189208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
190209-- will be declared (regardless of whether it is recusive or not).
191−declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
192211declareSchemaRef proxy = do
193212 case toNamedSchema proxy of
194213 NamedSchema (Just name) schema -> do
@@ -250,7 +269,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
250269--
251270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
252271-- when inlining recursive schemas.
253−toInlinedSchema :: ToSchema a => proxy a -> Schema
272+toInlinedSchema :: ToSchema a => Proxy a -> Schema
254273toInlinedSchema proxy = inlineAllSchemas defs schema
255274 where
256275 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -279,20 +298,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
279298-- | Default schema for binary data (any sequence of octets).
280299binarySchema :: Schema
281300binarySchema = mempty
282− & type_ .~ SwaggerString
301+ & type_ ?~ SwaggerString
283302 & format ?~ "binary"
284303
285304-- | Default schema for binary data (base64 encoded).
286305byteSchema :: Schema
287306byteSchema = mempty
288− & type_ .~ SwaggerString
307+ & type_ ?~ SwaggerString
289308 & format ?~ "byte"
290309
291310-- | Default schema for password string.
292311-- @"password"@ format is used to hint UIs the input needs to be obscured.
293312passwordSchema :: Schema
294313passwordSchema = mempty
295− & type_ .~ SwaggerString
314+ & type_ ?~ SwaggerString
296315 & format ?~ "password"
297316
298317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -318,12 +337,12 @@ sketchSchema = sketch . toJSON
318337 sketch js@(Bool _) = go js
319338 sketch js = go js & example ?~ js
320339
321− go Null = mempty & type_ .~ SwaggerNull
322− go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
323− go js@(String s) = mempty & type_ .~ SwaggerString
324− go js@(Number n) = mempty & type_ .~ SwaggerNumber
325− go js@(Array xs) = mempty
326− & type_ .~ SwaggerArray
340+ go Null = mempty & type_ ?~ SwaggerNull
341+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342+ go (String _) = mempty & type_ ?~ SwaggerString
343+ go (Number _) = mempty & type_ ?~ SwaggerNumber
344+ go (Array xs) = mempty
345+ & type_ ?~ SwaggerArray
327346 & items ?~ case ischema of
328347 Just s -> SwaggerItemsObject (Inline s)
329348 _ -> SwaggerItemsArray (map Inline ys)
@@ -332,10 +351,10 @@ sketchSchema = sketch . toJSON
332351 allSame = and ((zipWith (==)) ys (tail ys))
333352
334353 ischema = case ys of
335− (z:zs) | allSame -> Just z
336− _ -> Nothing
337− go js@(Object o) = mempty
338− & type_ .~ SwaggerObject
354+ (z:_) | allSame -> Just z
355+ _ -> Nothing
356+ go (Object o) = mempty
357+ & type_ ?~ SwaggerObject
339358 & required .~ HashMap.keys o
340359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
341360
@@ -358,24 +377,24 @@ sketchSchema = sketch . toJSON
358377sketchStrictSchema :: ToJSON a => a -> Schema
359378sketchStrictSchema = go . toJSON
360379 where
361− go Null = mempty & type_ .~ SwaggerNull
380+ go Null = mempty & type_ ?~ SwaggerNull
362381 go js@(Bool _) = mempty
363− & type_ .~ SwaggerBoolean
382+ & type_ ?~ SwaggerBoolean
364383 & enum_ ?~ [js]
365384 go js@(String s) = mempty
366− & type_ .~ SwaggerString
385+ & type_ ?~ SwaggerString
367386 & maxLength ?~ fromIntegral (T.length s)
368387 & minLength ?~ fromIntegral (T.length s)
369388 & pattern ?~ s
370389 & enum_ ?~ [js]
371390 go js@(Number n) = mempty
372− & type_ .~ SwaggerNumber
391+ & type_ ?~ SwaggerNumber
373392 & maximum_ ?~ n
374393 & minimum_ ?~ n
375394 & multipleOf ?~ n
376395 & enum_ ?~ [js]
377396 go js@(Array xs) = mempty
378− & type_ .~ SwaggerArray
397+ & type_ ?~ SwaggerArray
379398 & maxItems ?~ fromIntegral sz
380399 & minItems ?~ fromIntegral sz
381400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -385,7 +404,7 @@ sketchStrictSchema = go . toJSON
385404 sz = length xs
386405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
387406 go js@(Object o) = mempty
388− & type_ .~ SwaggerObject
407+ & type_ ?~ SwaggerObject
389408 & required .~ names
390409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
391410 & maxProperties ?~ fromIntegral (length names)
@@ -395,18 +414,19 @@ sketchStrictSchema = go . toJSON
395414 names = HashMap.keys o
396415
397416class GToSchema (f :: * -> *) where
398− gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
399418
400419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
401420 declareNamedSchema _ = do
402421 ref <- declareSchemaRef (Proxy :: Proxy a)
403422 return $ unnamed $ mempty
404− & type_ .~ SwaggerArray
423+ & type_ ?~ SwaggerArray
405424 & items ?~ SwaggerItemsObject ref
406425
407426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
408427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
409428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
410430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
411431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
412432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -426,6 +446,8 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
426446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
427447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
428448
449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450+
429451instance ToSchema a => ToSchema (Maybe a) where
430452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
431453
@@ -448,7 +470,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
448470
449471timeSchema :: T.Text -> Schema
450472timeSchema fmt = mempty
451− & type_ .~ SwaggerString
473+ & type_ ?~ SwaggerString
452474 & format ?~ fmt
453475
454476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -469,7 +491,7 @@ instance ToSchema ZonedTime where
469491 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
470492
471493instance ToSchema NominalDiffTime where
472− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
473495
474496-- |
475497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -481,6 +503,20 @@ instance ToSchema UTCTime where
481503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
482504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
483505
506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507+
508+#if __GLASGOW_HASKELL__ < 800
509+#else
510+type family ToSchemaByteStringError bs where
511+ ToSchemaByteStringError bs = TypeError
512+ ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
513+ :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
514+ :$$: Text "Consider using byteSchema or binarySchema templates." )
515+
516+instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"
517+instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"
518+#endif
519+
484520instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
485521
486522-- | NOTE: This schema does not account for the uniqueness of keys.
@@ -496,8 +532,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
496532 declareObjectMapSchema = do
497533 schema <- declareSchemaRef (Proxy :: Proxy v)
498534 return $ unnamed $ mempty
499− & type_ .~ SwaggerObject
500− & additionalProperties ?~ schema
535+ & type_ ?~ SwaggerObject
536+ & additionalProperties ?~ AdditionalPropertiesSchema schema
501537
502538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
503539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -508,7 +544,7 @@ instance ToSchema a => ToSchema (Map String a) where
508544 declareNamedSchema _ = do
509545 schema <- declareSchemaRef (Proxy :: Proxy a)
510546 return $ unnamed $ mempty
511− & type_ .~ SwaggerObject
547+ & type_ ?~ SwaggerObject
512548 & additionalProperties ?~ schema
513549
514550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -520,6 +556,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
520556
521557#endif
522558
559+instance OVERLAPPING_ ToSchema Object where
560+ declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
561+ & type_ ?~ SwaggerObject
562+ & description ?~ "Arbitrary JSON object."
563+ & additionalProperties ?~ AdditionalPropertiesAllowed True
564+
523565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
524566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
525567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -533,6 +575,13 @@ instance ToSchema a => ToSchema (Set a) where
533575
534576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
535577
578+-- | @since 2.2.1
579+instance ToSchema a => ToSchema (NonEmpty a) where
580+ declareNamedSchema _ = do
581+ schema <- declareSchema (Proxy :: Proxy [a])
582+ return $ unnamed $ schema
583+ & minItems .~ Just 1
584+
536585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
537586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
538587
@@ -542,61 +591,141 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
542591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
543592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
544593
594+instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595+
545596-- | Default schema for @'Bounded'@, @'Integral'@ types.
546597--
547598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
548599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
549−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
550601toSchemaBoundedIntegral _ = mempty
551− & type_ .~ SwaggerInteger
602+ & type_ ?~ SwaggerInteger
552603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
553604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
554605
555606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
556−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
607+genericToNamedSchemaBoundedIntegral :: forall a d f.
557608 ( Bounded a, Integral a
558609 , Generic a, Rep a ~ D1 d f, Datatype d)
559− => SchemaOptions -> proxy a -> NamedSchema
610+ => SchemaOptions -> Proxy a -> NamedSchema
560611genericToNamedSchemaBoundedIntegral opts proxy
561− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
612+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613+
614+-- | Declare a named schema for a @newtype@ wrapper.
615+genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617+ => SchemaOptions -- ^ How to derive the name.
618+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619+ -> Proxy a
620+ -> Declare (Definitions Schema) NamedSchema
621+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622+
623+-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624+-- This makes a much more useful schema when there aren't many options for key values.
625+--
626+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627+-- >>> instance ToJSON ButtonState
628+-- >>> instance ToSchema ButtonState
629+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630+-- >>> type ImageUrl = T.Text
631+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633+--
634+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636+declareSchemaBoundedEnumKeyMapping :: forall map key value.
637+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638+ => Proxy (map key value) -> Declare (Definitions Schema) Schema
639+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640+ ToJSONKeyText keyToText _ -> objectSchema keyToText
641+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642+ where
643+ objectSchema keyToText = do
644+ valueRef <- declareSchemaRef (Proxy :: Proxy value)
645+ let allKeys = [minBound..maxBound :: key]
646+ mkPair k = (keyToText k, valueRef)
647+ return $ mempty
648+ & type_ ?~ SwaggerObject
649+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650+
651+-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652+-- This makes a much more useful schema when there aren't many options for key values.
653+--
654+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655+-- >>> instance ToJSON ButtonState
656+-- >>> instance ToSchema ButtonState
657+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658+-- >>> type ImageUrl = T.Text
659+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661+--
662+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664+toSchemaBoundedEnumKeyMapping :: forall map key value.
665+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666+ => Proxy (map key value) -> Schema
667+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
562668
563669-- | A configurable generic @'Schema'@ creator.
564−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
565−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
670+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672+genericDeclareSchema = genericDeclareSchemaUnrestricted
566673
567674-- | A configurable generic @'NamedSchema'@ creator.
568675-- This function applied to @'defaultSchemaOptions'@
569676-- is used as the default for @'declareNamedSchema'@
570677-- when the type is an instance of @'Generic'@.
571−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
572−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
678+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
680+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
681+
682+-- | A configurable generic @'Schema'@ creator.
683+--
684+-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688+
689+-- | A configurable generic @'NamedSchema'@ creator.
690+--
691+-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693+genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
695+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696+
697+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698+genericNameSchema :: forall a d f.
699+ (Generic a, Rep a ~ D1 d f, Datatype d)
700+ => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
573702
574−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
575−gdatatypeSchemaName opts _ = case name of
703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704+gdatatypeSchemaName opts _ = case orig of
576705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
577706 _ -> Nothing
578707 where
579− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)
709+ name = datatypeNameModifier opts orig
580710
581711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
582−paramSchemaToNamedSchema :: forall a d f proxy.
583− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
584− => SchemaOptions -> proxy a -> NamedSchema
585−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
712+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713+ SchemaOptions -> Proxy a -> NamedSchema
714+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
586715
587716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
588−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
589−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
590719
591720nullarySchema :: Schema
592721nullarySchema = mempty
593− & type_ .~ SwaggerArray
722+ & type_ ?~ SwaggerArray
594723 & items ?~ SwaggerItemsArray []
595724
596−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
597726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
598727
599−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
600729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
601730
602731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -616,7 +745,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
616745 gdeclareNamedSchema = gdeclareNamedSumSchema
617746
618747-- | Single field constructor.
619−instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
748+instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
620749 gdeclareNamedSchema opts _ s
621750 | unwrapUnaryRecords opts = fieldSchema
622751 | otherwise =
@@ -630,7 +759,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
630759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
631760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
632761
633−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
634763gdeclareSchemaRef opts proxy = do
635764 case gtoNamedSchema opts proxy of
636765 NamedSchema (Just name) schema -> do
@@ -649,7 +778,7 @@ gdeclareSchemaRef opts proxy = do
649778 return $ Ref (Reference name)
650779 _ -> Inline <$> gdeclareSchema opts proxy
651780
652−appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
781+appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
653782appendItem x Nothing = Just (SwaggerItemsArray [x])
654783appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
655784appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
@@ -661,10 +790,12 @@ withFieldSchema opts _ isRequiredField schema = do
661790 return $
662791 if T.null fname
663792 then schema
664− & type_ .~ SwaggerArray
793+ & type_ ?~ SwaggerArray
665794 & items %~ appendItem ref
795+ & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796+ & minItems %~ Just . maybe 1 (+1) -- increment minItems
666797 else schema
667− & type_ .~ SwaggerObject
798+ & type_ ?~ SwaggerObject
668799 & properties . at fname ?~ ref
669800 & if isRequiredField
670801 then required %~ (++ [fname])
@@ -686,10 +817,13 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
686817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
687818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
688819
689−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
820+instance ( GSumToSchema f
821+ , GSumToSchema g
822+ ) => GToSchema (f :+: g)
823+ where
690824 gdeclareNamedSchema = gdeclareNamedSumSchema
691825
692−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
826+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
693827gdeclareNamedSumSchema opts proxy s
694828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
695829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -698,29 +832,29 @@ gdeclareNamedSumSchema opts proxy s
698832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
699833
700834 toStringTag schema = mempty
701− & type_ .~ SwaggerString
835+ & type_ ?~ SwaggerString
702836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
703837
704838type AllNullary = All
705839
706−class GSumToSchema f where
707− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
840+class GSumToSchema (f :: * -> *) where
841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
708842
709843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
710844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
711845
712−gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
713− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
714848gsumConToSchemaWith ref opts _ schema = schema
715− & type_ .~ SwaggerObject
849+ & type_ ?~ SwaggerObject
716850 & properties . at tag ?~ ref
717851 & maxProperties ?~ 1
718852 & minProperties ?~ 1
719853 where
720854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
721855
722−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
723− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
856+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
724858gsumConToSchema opts proxy schema = do
725859 ref <- gdeclareSchemaRef opts proxy
726860 return $ gsumConToSchemaWith ref opts proxy schema
@@ -742,3 +876,7 @@ data Proxy2 a b = Proxy2
742876
743877data Proxy3 a b c = Proxy3
744878
879+-- $setup
880+-- >>> import Data.Swagger
881+-- >>> import Data.Aeson (encode)
882+-- >>> import Data.Aeson.Types (toJSONKeyText)