@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
@@ -31,7 +32,7 @@ import Data.Data.Lens (template)
32import Control.Monad
33import Control.Monad
33import Control.Monad.Writer
34import Control.Monad.Writer
34−import Data.Aeson
35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
35import Data.Char
36import Data.Char
36import Data.Data (Data)
37import Data.Data (Data)
37import Data.Foldable (traverse_)
38import Data.Foldable (traverse_)
@@ -43,9 +44,11 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
43import Data.Int
44import Data.Int
44import Data.IntSet (IntSet)
45import Data.IntSet (IntSet)
45import Data.IntMap (IntMap)
46import Data.IntMap (IntMap)
47+import Data.List.NonEmpty.Compat (NonEmpty)
46import Data.Map (Map)
48import Data.Map (Map)
47import Data.Proxy
49import Data.Proxy
48import Data.Scientific (Scientific)
50import Data.Scientific (Scientific)
51+import Data.Fixed (Fixed, HasResolution, Pico)
49import Data.Set (Set)
52import Data.Set (Set)
50import qualified Data.Text as T
53import qualified Data.Text as T
51import qualified Data.Text.Lazy as TL
54import qualified Data.Text.Lazy as TL
@@ -54,6 +57,8 @@ import qualified Data.Vector as V
54import qualified Data.Vector.Primitive as VP
57import qualified Data.Vector.Primitive as VP
55import qualified Data.Vector.Storable as VS
58import qualified Data.Vector.Storable as VS
56import qualified Data.Vector.Unboxed as VU
59import qualified Data.Vector.Unboxed as VU
60+import Data.Version (Version)
61+import Numeric.Natural.Compat (Natural)
57import Data.Word
62import Data.Word
58import GHC.Generics
63import GHC.Generics
59import qualified Data.UUID.Types as UUID
64import qualified Data.UUID.Types as UUID
@@ -64,10 +69,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
64import Data.Swagger.Lens hiding (name, schema)
69import Data.Swagger.Lens hiding (name, schema)
65import qualified Data.Swagger.Lens as Swagger
70import qualified Data.Swagger.Lens as Swagger
66import Data.Swagger.SchemaOptions
71import Data.Swagger.SchemaOptions
69−import Data.Swagger.Lens (name, schema)
72+import Data.Swagger.Internal.TypeShape
72#if __GLASGOW_HASKELL__ < 800
74#if __GLASGOW_HASKELL__ < 800
@@ -109,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
109-- declareNamedSchema _ = do
111-- declareNamedSchema _ = do
110-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
111-- return $ NamedSchema (Just \"Coord\") $ mempty
113-- return $ NamedSchema (Just \"Coord\") $ mempty
112−-- & type_ .~ SwaggerObject
114+-- & type_ ?~ SwaggerObject
113-- & properties .~
115-- & properties .~
114-- [ (\"x\", doubleSchema)
116-- [ (\"x\", doubleSchema)
115-- , (\"y\", doubleSchema)
117-- , (\"y\", doubleSchema)
@@ -140,12 +142,17 @@ class ToSchema a where
140 -- together with all used definitions.
142 -- together with all used definitions.
141 -- Note that the schema itself is included in definitions
143 -- Note that the schema itself is included in definitions
142 -- only if it is recursive (and thus needs its definition in scope).
144 -- only if it is recursive (and thus needs its definition in scope).
143− declareNamedSchema :: 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") =>
144− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
147+ Proxy a -> Declare (Definitions Schema) NamedSchema
145 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
150+instance ToSchema TimeOfDay where
151+ declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152+ & example ?~ toJSON (TimeOfDay 12 33 15)
147-- | Convert a type into a schema and declare all used schema definitions.
154-- | Convert a type into a schema and declare all used schema definitions.
148−declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
155+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
149declareSchema = fmap _namedSchemaSchema . declareNamedSchema
156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
151-- | Convert a type into an optionally named schema.
158-- | Convert a type into an optionally named schema.
@@ -159,7 +166,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
159-- Just "Day"
166-- Just "Day"
160-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
161-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
162−toNamedSchema :: ToSchema a => proxy a -> NamedSchema
169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
163toNamedSchema = undeclare . declareNamedSchema
170toNamedSchema = undeclare . declareNamedSchema
165-- | Get type's schema name according to its @'ToSchema'@ instance.
172-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -169,7 +176,7 @@ toNamedSchema = undeclare . declareNamedSchema
170-- >>> schemaName (Proxy :: Proxy UTCTime)
177-- >>> schemaName (Proxy :: Proxy UTCTime)
171-- Just "UTCTime"
178-- Just "UTCTime"
172−schemaName :: ToSchema a => proxy a -> Maybe T.Text
179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text
173schemaName = _namedSchemaName . toNamedSchema
180schemaName = _namedSchemaName . toNamedSchema
175-- | Convert a type into a schema.
182-- | Convert a type into a schema.
@@ -179,7 +186,7 @@ schemaName = _namedSchemaName . toNamedSchema
180-- >>> encode $ toSchema (Proxy :: Proxy [Day])
187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
181-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
182−toSchema :: ToSchema a => proxy a -> Schema
189+toSchema :: ToSchema a => Proxy a -> Schema
183toSchema = _namedSchemaSchema . toNamedSchema
190toSchema = _namedSchemaSchema . toNamedSchema
185-- | Convert a type into a referenced schema if possible.
192-- | Convert a type into a referenced schema if possible.
@@ -190,7 +197,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
191-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
192-- "{\"$ref\":\"#/definitions/Day\"}"
199-- "{\"$ref\":\"#/definitions/Day\"}"
193−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
194toSchemaRef = undeclare . declareSchemaRef
201toSchemaRef = undeclare . declareSchemaRef
196-- | Convert a type into a referenced schema if possible
203-- | Convert a type into a referenced schema if possible
@@ -200,7 +207,7 @@ toSchemaRef = undeclare . declareSchemaRef
200-- Schema definitions are typically declared for every referenced schema.
207-- Schema definitions are typically declared for every referenced schema.
201-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
202-- will be declared (regardless of whether it is recusive or not).
209-- will be declared (regardless of whether it is recusive or not).
203−declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
204declareSchemaRef proxy = do
211declareSchemaRef proxy = do
205 case toNamedSchema proxy of
212 case toNamedSchema proxy of
206 NamedSchema (Just name) schema -> do
213 NamedSchema (Just name) schema -> do
@@ -262,7 +269,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
263-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
264-- when inlining recursive schemas.
271-- when inlining recursive schemas.
265−toInlinedSchema :: ToSchema a => proxy a -> Schema
272+toInlinedSchema :: ToSchema a => Proxy a -> Schema
266toInlinedSchema proxy = inlineAllSchemas defs schema
273toInlinedSchema proxy = inlineAllSchemas defs schema
268 (defs, schema) = runDeclare (declareSchema proxy) mempty
275 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -291,20 +298,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
291-- | Default schema for binary data (any sequence of octets).
298-- | Default schema for binary data (any sequence of octets).
292binarySchema :: Schema
299binarySchema :: Schema
293binarySchema = mempty
300binarySchema = mempty
294− & type_ .~ SwaggerString
301+ & type_ ?~ SwaggerString
295 & format ?~ "binary"
302 & format ?~ "binary"
297-- | Default schema for binary data (base64 encoded).
304-- | Default schema for binary data (base64 encoded).
298byteSchema :: Schema
305byteSchema :: Schema
299byteSchema = mempty
306byteSchema = mempty
300− & type_ .~ SwaggerString
307+ & type_ ?~ SwaggerString
301 & format ?~ "byte"
308 & format ?~ "byte"
303-- | Default schema for password string.
310-- | Default schema for password string.
304-- @"password"@ format is used to hint UIs the input needs to be obscured.
311-- @"password"@ format is used to hint UIs the input needs to be obscured.
305passwordSchema :: Schema
312passwordSchema :: Schema
306passwordSchema = mempty
313passwordSchema = mempty
307− & type_ .~ SwaggerString
314+ & type_ ?~ SwaggerString
308 & format ?~ "password"
315 & format ?~ "password"
310-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -330,12 +337,12 @@ sketchSchema = sketch . toJSON
330 sketch js@(Bool _) = go js
337 sketch js@(Bool _) = go js
331 sketch js = go js & example ?~ js
338 sketch js = go js & example ?~ js
333− go Null = mempty & type_ .~ SwaggerNull
340+ go Null = mempty & type_ ?~ SwaggerNull
334− go (Bool _) = mempty & type_ .~ SwaggerBoolean
341+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean
335− go (String _) = mempty & type_ .~ SwaggerString
342+ go (String _) = mempty & type_ ?~ SwaggerString
336− go (Number _) = mempty & type_ .~ SwaggerNumber
343+ go (Number _) = mempty & type_ ?~ SwaggerNumber
337 go (Array xs) = mempty
344 go (Array xs) = mempty
338− & type_ .~ SwaggerArray
345+ & type_ ?~ SwaggerArray
339 & items ?~ case ischema of
346 & items ?~ case ischema of
340 Just s -> SwaggerItemsObject (Inline s)
347 Just s -> SwaggerItemsObject (Inline s)
341 _ -> SwaggerItemsArray (map Inline ys)
348 _ -> SwaggerItemsArray (map Inline ys)
@@ -347,7 +354,7 @@ sketchSchema = sketch . toJSON
347 (z:_) | allSame -> Just z
354 (z:_) | allSame -> Just z
348 _ -> Nothing
355 _ -> Nothing
349 go (Object o) = mempty
356 go (Object o) = mempty
350− & type_ .~ SwaggerObject
357+ & type_ ?~ SwaggerObject
351 & required .~ HashMap.keys o
358 & required .~ HashMap.keys o
352 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
@@ -370,24 +377,24 @@ sketchSchema = sketch . toJSON
370sketchStrictSchema :: ToJSON a => a -> Schema
377sketchStrictSchema :: ToJSON a => a -> Schema
371sketchStrictSchema = go . toJSON
378sketchStrictSchema = go . toJSON
373− go Null = mempty & type_ .~ SwaggerNull
380+ go Null = mempty & type_ ?~ SwaggerNull
374 go js@(Bool _) = mempty
381 go js@(Bool _) = mempty
375− & type_ .~ SwaggerBoolean
382+ & type_ ?~ SwaggerBoolean
376 & enum_ ?~ [js]
383 & enum_ ?~ [js]
377 go js@(String s) = mempty
384 go js@(String s) = mempty
378− & type_ .~ SwaggerString
385+ & type_ ?~ SwaggerString
379 & maxLength ?~ fromIntegral (T.length s)
386 & maxLength ?~ fromIntegral (T.length s)
380 & minLength ?~ fromIntegral (T.length s)
387 & minLength ?~ fromIntegral (T.length s)
381 & pattern ?~ s
388 & pattern ?~ s
382 & enum_ ?~ [js]
389 & enum_ ?~ [js]
383 go js@(Number n) = mempty
390 go js@(Number n) = mempty
384− & type_ .~ SwaggerNumber
391+ & type_ ?~ SwaggerNumber
385 & maximum_ ?~ n
392 & maximum_ ?~ n
386 & minimum_ ?~ n
393 & minimum_ ?~ n
387 & multipleOf ?~ n
394 & multipleOf ?~ n
388 & enum_ ?~ [js]
395 & enum_ ?~ [js]
389 go js@(Array xs) = mempty
396 go js@(Array xs) = mempty
390− & type_ .~ SwaggerArray
397+ & type_ ?~ SwaggerArray
391 & maxItems ?~ fromIntegral sz
398 & maxItems ?~ fromIntegral sz
392 & minItems ?~ fromIntegral sz
399 & minItems ?~ fromIntegral sz
393 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -397,7 +404,7 @@ sketchStrictSchema = go . toJSON
397 sz = length xs
404 sz = length xs
398 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
399 go js@(Object o) = mempty
406 go js@(Object o) = mempty
400− & type_ .~ SwaggerObject
407+ & type_ ?~ SwaggerObject
401 & required .~ names
408 & required .~ names
402 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
403 & maxProperties ?~ fromIntegral (length names)
410 & maxProperties ?~ fromIntegral (length names)
@@ -407,18 +414,19 @@ sketchStrictSchema = go . toJSON
407 names = HashMap.keys o
414 names = HashMap.keys o
409class GToSchema (f :: * -> *) where
416class GToSchema (f :: * -> *) where
410− gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
412instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
413 declareNamedSchema _ = do
420 declareNamedSchema _ = do
414 ref <- declareSchemaRef (Proxy :: Proxy a)
421 ref <- declareSchemaRef (Proxy :: Proxy a)
415 return $ unnamed $ mempty
422 return $ unnamed $ mempty
416− & type_ .~ SwaggerArray
423+ & type_ ?~ SwaggerArray
417 & items ?~ SwaggerItemsObject ref
424 & items ?~ SwaggerItemsObject ref
419instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
420instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
421instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
422instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
423instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
424instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -438,6 +446,8 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
438instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
439instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
441instance ToSchema a => ToSchema (Maybe a) where
451instance ToSchema a => ToSchema (Maybe a) where
442 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -460,7 +470,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
461timeSchema :: T.Text -> Schema
471timeSchema :: T.Text -> Schema
462timeSchema fmt = mempty
472timeSchema fmt = mempty
463− & type_ .~ SwaggerString
473+ & type_ ?~ SwaggerString
464 & format ?~ fmt
474 & format ?~ fmt
466-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -481,7 +491,7 @@ instance ToSchema ZonedTime where
481 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
491 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
483instance ToSchema NominalDiffTime where
493instance ToSchema NominalDiffTime where
484− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
487-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -493,6 +503,8 @@ instance ToSchema UTCTime where
493instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
494instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
496#if __GLASGOW_HASKELL__ < 800
508#if __GLASGOW_HASKELL__ < 800
498type family ToSchemaByteStringError bs where
510type family ToSchemaByteStringError bs where
@@ -520,8 +532,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
520 declareObjectMapSchema = do
532 declareObjectMapSchema = do
521 schema <- declareSchemaRef (Proxy :: Proxy v)
533 schema <- declareSchemaRef (Proxy :: Proxy v)
522 return $ unnamed $ mempty
534 return $ unnamed $ mempty
523− & type_ .~ SwaggerObject
535+ & type_ ?~ SwaggerObject
524− & additionalProperties ?~ schema
536+ & additionalProperties ?~ AdditionalPropertiesSchema schema
526instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
527 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -532,7 +544,7 @@ instance ToSchema a => ToSchema (Map String a) where
532 declareNamedSchema _ = do
544 declareNamedSchema _ = do
533 schema <- declareSchemaRef (Proxy :: Proxy a)
545 schema <- declareSchemaRef (Proxy :: Proxy a)
534 return $ unnamed $ mempty
546 return $ unnamed $ mempty
535− & type_ .~ SwaggerObject
547+ & type_ ?~ SwaggerObject
536 & additionalProperties ?~ schema
548 & additionalProperties ?~ schema
538instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -544,6 +556,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
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
547instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
548instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
549instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -557,6 +575,13 @@ instance ToSchema a => ToSchema (Set a) where
558instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
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
560instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
561instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
@@ -566,61 +591,141 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
566instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
567instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
594+instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
569-- | Default schema for @'Bounded'@, @'Integral'@ types.
596-- | Default schema for @'Bounded'@, @'Integral'@ types.
571-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
572-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
573−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
574toSchemaBoundedIntegral _ = mempty
601toSchemaBoundedIntegral _ = mempty
575− & type_ .~ SwaggerInteger
602+ & type_ ?~ SwaggerInteger
576 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
577 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
579-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
580−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
607+genericToNamedSchemaBoundedIntegral :: forall a d f.
581 ( Bounded a, Integral a
608 ( Bounded a, Integral a
582 , Generic a, Rep a ~ D1 d f, Datatype d)
609 , Generic a, Rep a ~ D1 d f, Datatype d)
583− => SchemaOptions -> proxy a -> NamedSchema
610+ => SchemaOptions -> Proxy a -> NamedSchema
584genericToNamedSchemaBoundedIntegral opts proxy
611genericToNamedSchemaBoundedIntegral opts proxy
585− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
612+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
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.
620+ -> Declare (Definitions Schema) NamedSchema
621+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
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.
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\"}"
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)])
643+ objectSchema keyToText = do
644+ valueRef <- declareSchemaRef (Proxy :: Proxy value)
645+ let allKeys = [minBound..maxBound :: key]
646+ mkPair k = (keyToText k, valueRef)
648+ & type_ ?~ SwaggerObject
649+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
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.
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\"}"
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
587-- | A configurable generic @'Schema'@ creator.
669-- | A configurable generic @'Schema'@ creator.
670+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
588−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
589−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
672+genericDeclareSchema = genericDeclareSchemaUnrestricted
591-- | A configurable generic @'NamedSchema'@ creator.
674-- | A configurable generic @'NamedSchema'@ creator.
592-- This function applied to @'defaultSchemaOptions'@
675-- This function applied to @'defaultSchemaOptions'@
593-- is used as the default for @'declareNamedSchema'@
676-- is used as the default for @'declareNamedSchema'@
594-- when the type is an instance of @'Generic'@.
677-- when the type is an instance of @'Generic'@.
678+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
680+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
682+-- | A configurable generic @'Schema'@ creator.
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.
595−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
686+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
689+-- | A configurable generic @'NamedSchema'@ creator.
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
596−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
695+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
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))
598−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
599−gdatatypeSchemaName opts _ = case name of
704+gdatatypeSchemaName opts _ = case orig of
600 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
601 _ -> Nothing
706 _ -> Nothing
603− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)
709+ name = datatypeNameModifier opts orig
605-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
606−paramSchemaToNamedSchema :: forall a d f proxy.
607− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
712+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
608− => SchemaOptions -> proxy a -> NamedSchema
713+ SchemaOptions -> Proxy a -> NamedSchema
609−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
714+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
611-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
612−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
613−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
615nullarySchema :: Schema
720nullarySchema :: Schema
616nullarySchema = mempty
721nullarySchema = mempty
617− & type_ .~ SwaggerArray
722+ & type_ ?~ SwaggerArray
618 & items ?~ SwaggerItemsArray []
723 & items ?~ SwaggerItemsArray []
620−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
621gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
623−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
624gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
626instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -640,7 +745,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
640 gdeclareNamedSchema = gdeclareNamedSumSchema
745 gdeclareNamedSchema = gdeclareNamedSumSchema
642-- | Single field constructor.
747-- | Single field constructor.
643−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
644 gdeclareNamedSchema opts _ s
749 gdeclareNamedSchema opts _ s
645 | unwrapUnaryRecords opts = fieldSchema
750 | unwrapUnaryRecords opts = fieldSchema
646 | otherwise =
751 | otherwise =
@@ -654,7 +759,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
654 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
655 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
657−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
658gdeclareSchemaRef opts proxy = do
763gdeclareSchemaRef opts proxy = do
659 case gtoNamedSchema opts proxy of
764 case gtoNamedSchema opts proxy of
660 NamedSchema (Just name) schema -> do
765 NamedSchema (Just name) schema -> do
@@ -685,12 +790,12 @@ withFieldSchema opts _ isRequiredField schema = do
686 if T.null fname
791 if T.null fname
687 then schema
792 then schema
688− & type_ .~ SwaggerArray
793+ & type_ ?~ SwaggerArray
689 & items %~ appendItem ref
794 & items %~ appendItem ref
690 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
795 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
691 & minItems %~ Just . maybe 1 (+1) -- increment minItems
796 & minItems %~ Just . maybe 1 (+1) -- increment minItems
692 else schema
797 else schema
693− & type_ .~ SwaggerObject
798+ & type_ ?~ SwaggerObject
694 & properties . at fname ?~ ref
799 & properties . at fname ?~ ref
695 & if isRequiredField
800 & if isRequiredField
696 then required %~ (++ [fname])
801 then required %~ (++ [fname])
@@ -712,10 +817,13 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
712instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
713 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
715−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
820+instance ( GSumToSchema f
822+ ) => GToSchema (f :+: g)
716 gdeclareNamedSchema = gdeclareNamedSumSchema
824 gdeclareNamedSchema = gdeclareNamedSumSchema
718−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
826+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
719gdeclareNamedSumSchema opts proxy s
827gdeclareNamedSumSchema opts proxy s
720 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
721 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -724,29 +832,29 @@ gdeclareNamedSumSchema opts proxy s
724 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
726 toStringTag schema = mempty
834 toStringTag schema = mempty
727− & type_ .~ SwaggerString
835+ & type_ ?~ SwaggerString
728 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
730type AllNullary = All
838type AllNullary = All
732−class GSumToSchema f where
840+class GSumToSchema (f :: * -> *) where
733− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
735instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
736 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
738−gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
739− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
740gsumConToSchemaWith ref opts _ schema = schema
848gsumConToSchemaWith ref opts _ schema = schema
741− & type_ .~ SwaggerObject
849+ & type_ ?~ SwaggerObject
742 & properties . at tag ?~ ref
850 & properties . at tag ?~ ref
743 & maxProperties ?~ 1
851 & maxProperties ?~ 1
744 & minProperties ?~ 1
852 & minProperties ?~ 1
746 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
748−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
856+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
749− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
857+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
750gsumConToSchema opts proxy schema = do
858gsumConToSchema opts proxy schema = do
751 ref <- gdeclareSchemaRef opts proxy
859 ref <- gdeclareSchemaRef opts proxy
752 return $ gsumConToSchemaWith ref opts proxy schema
860 return $ gsumConToSchemaWith ref opts proxy schema
@@ -768,3 +876,7 @@ data Proxy2 a b = Proxy2
769data Proxy3 a b c = Proxy3
877data Proxy3 a b c = Proxy3
880+-- >>> import Data.Swagger
881+-- >>> import Data.Aeson (encode)
882+-- >>> import Data.Aeson.Types (toJSONKeyText)