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