@@ -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,6 +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
72+import Data.Swagger.Internal.TypeShape
68#if __GLASGOW_HASKELL__ < 800
74#if __GLASGOW_HASKELL__ < 800
@@ -105,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
105-- declareNamedSchema _ = do
111-- declareNamedSchema _ = do
106-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
107-- return $ NamedSchema (Just \"Coord\") $ mempty
113-- return $ NamedSchema (Just \"Coord\") $ mempty
108−-- & type_ .~ SwaggerObject
114+-- & type_ ?~ SwaggerObject
109-- & properties .~
115-- & properties .~
110-- [ (\"x\", doubleSchema)
116-- [ (\"x\", doubleSchema)
111-- , (\"y\", doubleSchema)
117-- , (\"y\", doubleSchema)
@@ -136,12 +142,17 @@ class ToSchema a where
136 -- together with all used definitions.
142 -- together with all used definitions.
137 -- Note that the schema itself is included in definitions
143 -- Note that the schema itself is included in definitions
138 -- 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).
139− 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") =>
140− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
147+ Proxy a -> Declare (Definitions Schema) NamedSchema
141 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)
143-- | 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.
144−declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
155+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
145declareSchema = fmap _namedSchemaSchema . declareNamedSchema
156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
147-- | Convert a type into an optionally named schema.
158-- | Convert a type into an optionally named schema.
@@ -155,7 +166,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
155-- Just "Day"
166-- Just "Day"
156-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
157-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
158−toNamedSchema :: ToSchema a => proxy a -> NamedSchema
169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
159toNamedSchema = undeclare . declareNamedSchema
170toNamedSchema = undeclare . declareNamedSchema
161-- | Get type's schema name according to its @'ToSchema'@ instance.
172-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -165,7 +176,7 @@ toNamedSchema = undeclare . declareNamedSchema
166-- >>> schemaName (Proxy :: Proxy UTCTime)
177-- >>> schemaName (Proxy :: Proxy UTCTime)
167-- Just "UTCTime"
178-- Just "UTCTime"
168−schemaName :: ToSchema a => proxy a -> Maybe T.Text
179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text
169schemaName = _namedSchemaName . toNamedSchema
180schemaName = _namedSchemaName . toNamedSchema
171-- | Convert a type into a schema.
182-- | Convert a type into a schema.
@@ -175,7 +186,7 @@ schemaName = _namedSchemaName . toNamedSchema
176-- >>> encode $ toSchema (Proxy :: Proxy [Day])
187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
177-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
178−toSchema :: ToSchema a => proxy a -> Schema
189+toSchema :: ToSchema a => Proxy a -> Schema
179toSchema = _namedSchemaSchema . toNamedSchema
190toSchema = _namedSchemaSchema . toNamedSchema
181-- | Convert a type into a referenced schema if possible.
192-- | Convert a type into a referenced schema if possible.
@@ -186,7 +197,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
187-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
188-- "{\"$ref\":\"#/definitions/Day\"}"
199-- "{\"$ref\":\"#/definitions/Day\"}"
189−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
190toSchemaRef = undeclare . declareSchemaRef
201toSchemaRef = undeclare . declareSchemaRef
192-- | Convert a type into a referenced schema if possible
203-- | Convert a type into a referenced schema if possible
@@ -196,7 +207,7 @@ toSchemaRef = undeclare . declareSchemaRef
196-- Schema definitions are typically declared for every referenced schema.
207-- Schema definitions are typically declared for every referenced schema.
197-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
198-- will be declared (regardless of whether it is recusive or not).
209-- will be declared (regardless of whether it is recusive or not).
199−declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
200declareSchemaRef proxy = do
211declareSchemaRef proxy = do
201 case toNamedSchema proxy of
212 case toNamedSchema proxy of
202 NamedSchema (Just name) schema -> do
213 NamedSchema (Just name) schema -> do
@@ -258,7 +269,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
259-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
260-- when inlining recursive schemas.
271-- when inlining recursive schemas.
261−toInlinedSchema :: ToSchema a => proxy a -> Schema
272+toInlinedSchema :: ToSchema a => Proxy a -> Schema
262toInlinedSchema proxy = inlineAllSchemas defs schema
273toInlinedSchema proxy = inlineAllSchemas defs schema
264 (defs, schema) = runDeclare (declareSchema proxy) mempty
275 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -287,20 +298,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
287-- | Default schema for binary data (any sequence of octets).
298-- | Default schema for binary data (any sequence of octets).
288binarySchema :: Schema
299binarySchema :: Schema
289binarySchema = mempty
300binarySchema = mempty
290− & type_ .~ SwaggerString
301+ & type_ ?~ SwaggerString
291 & format ?~ "binary"
302 & format ?~ "binary"
293-- | Default schema for binary data (base64 encoded).
304-- | Default schema for binary data (base64 encoded).
294byteSchema :: Schema
305byteSchema :: Schema
295byteSchema = mempty
306byteSchema = mempty
296− & type_ .~ SwaggerString
307+ & type_ ?~ SwaggerString
297 & format ?~ "byte"
308 & format ?~ "byte"
299-- | Default schema for password string.
310-- | Default schema for password string.
300-- @"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.
301passwordSchema :: Schema
312passwordSchema :: Schema
302passwordSchema = mempty
313passwordSchema = mempty
303− & type_ .~ SwaggerString
314+ & type_ ?~ SwaggerString
304 & format ?~ "password"
315 & format ?~ "password"
306-- | 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.
@@ -326,12 +337,12 @@ sketchSchema = sketch . toJSON
326 sketch js@(Bool _) = go js
337 sketch js@(Bool _) = go js
327 sketch js = go js & example ?~ js
338 sketch js = go js & example ?~ js
329− go Null = mempty & type_ .~ SwaggerNull
340+ go Null = mempty & type_ ?~ SwaggerNull
330− go (Bool _) = mempty & type_ .~ SwaggerBoolean
341+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean
331− go (String _) = mempty & type_ .~ SwaggerString
342+ go (String _) = mempty & type_ ?~ SwaggerString
332− go (Number _) = mempty & type_ .~ SwaggerNumber
343+ go (Number _) = mempty & type_ ?~ SwaggerNumber
333 go (Array xs) = mempty
344 go (Array xs) = mempty
334− & type_ .~ SwaggerArray
345+ & type_ ?~ SwaggerArray
335 & items ?~ case ischema of
346 & items ?~ case ischema of
336 Just s -> SwaggerItemsObject (Inline s)
347 Just s -> SwaggerItemsObject (Inline s)
337 _ -> SwaggerItemsArray (map Inline ys)
348 _ -> SwaggerItemsArray (map Inline ys)
@@ -343,7 +354,7 @@ sketchSchema = sketch . toJSON
343 (z:_) | allSame -> Just z
354 (z:_) | allSame -> Just z
344 _ -> Nothing
355 _ -> Nothing
345 go (Object o) = mempty
356 go (Object o) = mempty
346− & type_ .~ SwaggerObject
357+ & type_ ?~ SwaggerObject
347 & required .~ HashMap.keys o
358 & required .~ HashMap.keys o
348 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
@@ -366,24 +377,24 @@ sketchSchema = sketch . toJSON
366sketchStrictSchema :: ToJSON a => a -> Schema
377sketchStrictSchema :: ToJSON a => a -> Schema
367sketchStrictSchema = go . toJSON
378sketchStrictSchema = go . toJSON
369− go Null = mempty & type_ .~ SwaggerNull
380+ go Null = mempty & type_ ?~ SwaggerNull
370 go js@(Bool _) = mempty
381 go js@(Bool _) = mempty
371− & type_ .~ SwaggerBoolean
382+ & type_ ?~ SwaggerBoolean
372 & enum_ ?~ [js]
383 & enum_ ?~ [js]
373 go js@(String s) = mempty
384 go js@(String s) = mempty
374− & type_ .~ SwaggerString
385+ & type_ ?~ SwaggerString
375 & maxLength ?~ fromIntegral (T.length s)
386 & maxLength ?~ fromIntegral (T.length s)
376 & minLength ?~ fromIntegral (T.length s)
387 & minLength ?~ fromIntegral (T.length s)
377 & pattern ?~ s
388 & pattern ?~ s
378 & enum_ ?~ [js]
389 & enum_ ?~ [js]
379 go js@(Number n) = mempty
390 go js@(Number n) = mempty
380− & type_ .~ SwaggerNumber
391+ & type_ ?~ SwaggerNumber
381 & maximum_ ?~ n
392 & maximum_ ?~ n
382 & minimum_ ?~ n
393 & minimum_ ?~ n
383 & multipleOf ?~ n
394 & multipleOf ?~ n
384 & enum_ ?~ [js]
395 & enum_ ?~ [js]
385 go js@(Array xs) = mempty
396 go js@(Array xs) = mempty
386− & type_ .~ SwaggerArray
397+ & type_ ?~ SwaggerArray
387 & maxItems ?~ fromIntegral sz
398 & maxItems ?~ fromIntegral sz
388 & minItems ?~ fromIntegral sz
399 & minItems ?~ fromIntegral sz
389 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -393,7 +404,7 @@ sketchStrictSchema = go . toJSON
393 sz = length xs
404 sz = length xs
394 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
395 go js@(Object o) = mempty
406 go js@(Object o) = mempty
396− & type_ .~ SwaggerObject
407+ & type_ ?~ SwaggerObject
397 & required .~ names
408 & required .~ names
398 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
399 & maxProperties ?~ fromIntegral (length names)
410 & maxProperties ?~ fromIntegral (length names)
@@ -403,18 +414,19 @@ sketchStrictSchema = go . toJSON
403 names = HashMap.keys o
414 names = HashMap.keys o
405class GToSchema (f :: * -> *) where
416class GToSchema (f :: * -> *) where
406− gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
408instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
409 declareNamedSchema _ = do
420 declareNamedSchema _ = do
410 ref <- declareSchemaRef (Proxy :: Proxy a)
421 ref <- declareSchemaRef (Proxy :: Proxy a)
411 return $ unnamed $ mempty
422 return $ unnamed $ mempty
412− & type_ .~ SwaggerArray
423+ & type_ ?~ SwaggerArray
413 & items ?~ SwaggerItemsObject ref
424 & items ?~ SwaggerItemsObject ref
415instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
416instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
417instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
418instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
419instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
420instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -434,6 +446,8 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
434instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
435instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
437instance ToSchema a => ToSchema (Maybe a) where
451instance ToSchema a => ToSchema (Maybe a) where
438 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -456,7 +470,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
457timeSchema :: T.Text -> Schema
471timeSchema :: T.Text -> Schema
458timeSchema fmt = mempty
472timeSchema fmt = mempty
459− & type_ .~ SwaggerString
473+ & type_ ?~ SwaggerString
460 & format ?~ fmt
474 & format ?~ fmt
462-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -477,7 +491,7 @@ instance ToSchema ZonedTime where
477 & 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))
479instance ToSchema NominalDiffTime where
493instance ToSchema NominalDiffTime where
480− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
483-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -489,6 +503,8 @@ instance ToSchema UTCTime where
489instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
490instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
492#if __GLASGOW_HASKELL__ < 800
508#if __GLASGOW_HASKELL__ < 800
494type family ToSchemaByteStringError bs where
510type family ToSchemaByteStringError bs where
@@ -516,8 +532,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
516 declareObjectMapSchema = do
532 declareObjectMapSchema = do
517 schema <- declareSchemaRef (Proxy :: Proxy v)
533 schema <- declareSchemaRef (Proxy :: Proxy v)
518 return $ unnamed $ mempty
534 return $ unnamed $ mempty
519− & type_ .~ SwaggerObject
535+ & type_ ?~ SwaggerObject
520− & additionalProperties ?~ schema
536+ & additionalProperties ?~ AdditionalPropertiesSchema schema
522instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
523 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -528,7 +544,7 @@ instance ToSchema a => ToSchema (Map String a) where
528 declareNamedSchema _ = do
544 declareNamedSchema _ = do
529 schema <- declareSchemaRef (Proxy :: Proxy a)
545 schema <- declareSchemaRef (Proxy :: Proxy a)
530 return $ unnamed $ mempty
546 return $ unnamed $ mempty
531− & type_ .~ SwaggerObject
547+ & type_ ?~ SwaggerObject
532 & additionalProperties ?~ schema
548 & additionalProperties ?~ schema
534instance 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))
@@ -540,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
543instance 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])
544instance 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])
545instance 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])
@@ -553,6 +575,13 @@ instance ToSchema a => ToSchema (Set a) where
554instance 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
556instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
557instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
@@ -562,61 +591,141 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
562instance 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)
563instance 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)
565-- | Default schema for @'Bounded'@, @'Integral'@ types.
596-- | Default schema for @'Bounded'@, @'Integral'@ types.
567-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
568-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
569−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
570toSchemaBoundedIntegral _ = mempty
601toSchemaBoundedIntegral _ = mempty
571− & type_ .~ SwaggerInteger
602+ & type_ ?~ SwaggerInteger
572 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
573 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
575-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
576−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
607+genericToNamedSchemaBoundedIntegral :: forall a d f.
577 ( Bounded a, Integral a
608 ( Bounded a, Integral a
578 , Generic a, Rep a ~ D1 d f, Datatype d)
609 , Generic a, Rep a ~ D1 d f, Datatype d)
579− => SchemaOptions -> proxy a -> NamedSchema
610+ => SchemaOptions -> Proxy a -> NamedSchema
580genericToNamedSchemaBoundedIntegral opts proxy
611genericToNamedSchemaBoundedIntegral opts proxy
581− = 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
583-- | A configurable generic @'Schema'@ creator.
669-- | A configurable generic @'Schema'@ creator.
670+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
584−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
585−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
672+genericDeclareSchema = genericDeclareSchemaUnrestricted
587-- | A configurable generic @'NamedSchema'@ creator.
674-- | A configurable generic @'NamedSchema'@ creator.
588-- This function applied to @'defaultSchemaOptions'@
675-- This function applied to @'defaultSchemaOptions'@
589-- is used as the default for @'declareNamedSchema'@
676-- is used as the default for @'declareNamedSchema'@
590-- 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.
591−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
592−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))
594−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
595−gdatatypeSchemaName opts _ = case name of
704+gdatatypeSchemaName opts _ = case orig of
596 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
597 _ -> Nothing
706 _ -> Nothing
599− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)
709+ name = datatypeNameModifier opts orig
601-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
602−paramSchemaToNamedSchema :: forall a d f proxy.
603− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
712+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
604− => SchemaOptions -> proxy a -> NamedSchema
713+ SchemaOptions -> Proxy a -> NamedSchema
605−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
714+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
607-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
608−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
609−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
611nullarySchema :: Schema
720nullarySchema :: Schema
612nullarySchema = mempty
721nullarySchema = mempty
613− & type_ .~ SwaggerArray
722+ & type_ ?~ SwaggerArray
614 & items ?~ SwaggerItemsArray []
723 & items ?~ SwaggerItemsArray []
616−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
617gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
619−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
620gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
622instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -636,7 +745,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
636 gdeclareNamedSchema = gdeclareNamedSumSchema
745 gdeclareNamedSchema = gdeclareNamedSumSchema
638-- | Single field constructor.
747-- | Single field constructor.
639−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
640 gdeclareNamedSchema opts _ s
749 gdeclareNamedSchema opts _ s
641 | unwrapUnaryRecords opts = fieldSchema
750 | unwrapUnaryRecords opts = fieldSchema
642 | otherwise =
751 | otherwise =
@@ -650,7 +759,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
650 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
651 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
653−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
654gdeclareSchemaRef opts proxy = do
763gdeclareSchemaRef opts proxy = do
655 case gtoNamedSchema opts proxy of
764 case gtoNamedSchema opts proxy of
656 NamedSchema (Just name) schema -> do
765 NamedSchema (Just name) schema -> do
@@ -681,12 +790,12 @@ withFieldSchema opts _ isRequiredField schema = do
682 if T.null fname
791 if T.null fname
683 then schema
792 then schema
684− & type_ .~ SwaggerArray
793+ & type_ ?~ SwaggerArray
685 & items %~ appendItem ref
794 & items %~ appendItem ref
686 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
795 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
687 & minItems %~ Just . maybe 1 (+1) -- increment minItems
796 & minItems %~ Just . maybe 1 (+1) -- increment minItems
688 else schema
797 else schema
689− & type_ .~ SwaggerObject
798+ & type_ ?~ SwaggerObject
690 & properties . at fname ?~ ref
799 & properties . at fname ?~ ref
691 & if isRequiredField
800 & if isRequiredField
692 then required %~ (++ [fname])
801 then required %~ (++ [fname])
@@ -708,10 +817,13 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
708instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
709 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
711−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
820+instance ( GSumToSchema f
822+ ) => GToSchema (f :+: g)
712 gdeclareNamedSchema = gdeclareNamedSumSchema
824 gdeclareNamedSchema = gdeclareNamedSumSchema
714−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
826+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
715gdeclareNamedSumSchema opts proxy s
827gdeclareNamedSumSchema opts proxy s
716 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
717 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -720,29 +832,29 @@ gdeclareNamedSumSchema opts proxy s
720 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
722 toStringTag schema = mempty
834 toStringTag schema = mempty
723− & type_ .~ SwaggerString
835+ & type_ ?~ SwaggerString
724 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
726type AllNullary = All
838type AllNullary = All
728class GSumToSchema (f :: * -> *) where
840class GSumToSchema (f :: * -> *) where
729− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
731instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
732 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)
734−gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
735− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
736gsumConToSchemaWith ref opts _ schema = schema
848gsumConToSchemaWith ref opts _ schema = schema
737− & type_ .~ SwaggerObject
849+ & type_ ?~ SwaggerObject
738 & properties . at tag ?~ ref
850 & properties . at tag ?~ ref
739 & maxProperties ?~ 1
851 & maxProperties ?~ 1
740 & minProperties ?~ 1
852 & minProperties ?~ 1
742 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
744−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
856+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
745− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
857+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
746gsumConToSchema opts proxy schema = do
858gsumConToSchema opts proxy schema = do
747 ref <- gdeclareSchemaRef opts proxy
859 ref <- gdeclareSchemaRef opts proxy
748 return $ gsumConToSchemaWith ref opts proxy schema
860 return $ gsumConToSchemaWith ref opts proxy schema
@@ -766,3 +878,5 @@ data Proxy3 a b c = Proxy3
768-- >>> import Data.Swagger
880-- >>> import Data.Swagger
881+-- >>> import Data.Aeson (encode)
882+-- >>> import Data.Aeson.Types (toJSONKeyText)