@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DefaultSignatures #-}
43{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
@@ -14,13 +13,6 @@
1413{-# LANGUAGE TypeFamilies #-}
1514{-# LANGUAGE TypeOperators #-}
1615{-# LANGUAGE TypeSynonymInstances #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ >= 800
19−-- Few generics related redundant constraints
20−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
21−-- For TypeErrors
22−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
23−#endif
2416#include "overlapping-compat.h"
2517module Data.Swagger.Internal.Schema where
2618
@@ -30,25 +22,27 @@ import Prelude.Compat
3022import Control.Lens
3123import Data.Data.Lens (template)
3224
25+import Control.Applicative
3326import Control.Monad
3427import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
28+import Data.Aeson
29+import qualified Data.Aeson.Types as Aeson
3630import Data.Char
3731import Data.Data (Data)
3832import Data.Foldable (traverse_)
33+import Data.Function (on)
3934import Data.HashMap.Strict (HashMap)
4035import qualified Data.HashMap.Strict as HashMap
4136import "unordered-containers" Data.HashSet (HashSet)
4237import qualified "unordered-containers" Data.HashSet as HashSet
38+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
4339import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4440import Data.Int
4541import Data.IntSet (IntSet)
4642import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
4843import Data.Map (Map)
4944import Data.Proxy
5045import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
5246import Data.Set (Set)
5347import qualified Data.Text as T
5448import qualified Data.Text.Lazy as TL
@@ -57,25 +51,17 @@ import qualified Data.Vector as V
5751import qualified Data.Vector.Primitive as VP
5852import qualified Data.Vector.Storable as VS
5953import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
6254import Data.Word
6355import GHC.Generics
64−import qualified Data.UUID.Types as UUID
6556
6657import Data.Swagger.Declare
6758import Data.Swagger.Internal
6859import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
6960import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
7161import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
7362
74−#if __GLASGOW_HASKELL__ < 800
75−#else
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
63+#ifdef __DOCTEST__
64+import Data.Swagger.Lens (name, schema)
7965#endif
8066
8167unnamed :: Schema -> NamedSchema
@@ -102,16 +88,14 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
10288-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
10389--
10490-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
10791--
10892-- data Coord = Coord { x :: Double, y :: Double }
10993--
11094-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
95+-- declareNamedSchema = do
11296-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
97+-- return $ NamedSchema (Just \"Coord\")) $ mempty
98+-- & type_ .~ SwaggerObject
11599-- & properties .~
116100-- [ (\"x\", doubleSchema)
117101-- , (\"y\", doubleSchema)
@@ -142,17 +126,12 @@ class ToSchema a where
142126 -- together with all used definitions.
143127 -- Note that the schema itself is included in definitions
144128 -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
129+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
130+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148131 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149132
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154133-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
134+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156135declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157136
158137-- | Convert a type into an optionally named schema.
@@ -165,8 +144,8 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
165144-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166145-- Just "Day"
167146-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
147+-- "{\"format\":\"date\",\"type\":\"string\"}"
148+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170149toNamedSchema = undeclare . declareNamedSchema
171150
172151-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +155,7 @@ toNamedSchema = undeclare . declareNamedSchema
176155--
177156-- >>> schemaName (Proxy :: Proxy UTCTime)
178157-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
158+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180159schemaName = _namedSchemaName . toNamedSchema
181160
182161-- | Convert a type into a schema.
@@ -186,7 +165,7 @@ schemaName = _namedSchemaName . toNamedSchema
186165--
187166-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188167-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
168+toSchema :: ToSchema a => proxy a -> Schema
190169toSchema = _namedSchemaSchema . toNamedSchema
191170
192171-- | Convert a type into a referenced schema if possible.
@@ -197,7 +176,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197176--
198177-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199178-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
179+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201180toSchemaRef = undeclare . declareSchemaRef
202181
203182-- | Convert a type into a referenced schema if possible
@@ -207,7 +186,7 @@ toSchemaRef = undeclare . declareSchemaRef
207186-- Schema definitions are typically declared for every referenced schema.
208187-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209188-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
189+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211190declareSchemaRef proxy = do
212191 case toNamedSchema proxy of
213192 NamedSchema (Just name) schema -> do
@@ -265,11 +244,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)
265244-- | Convert a type into a schema without references.
266245--
267246-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
247+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269248--
270249-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271250-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
251+toInlinedSchema :: ToSchema a => proxy a -> Schema
273252toInlinedSchema proxy = inlineAllSchemas defs schema
274253 where
275254 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -298,20 +277,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
298277-- | Default schema for binary data (any sequence of octets).
299278binarySchema :: Schema
300279binarySchema = mempty
301− & type_ ?~ SwaggerString
280+ & type_ .~ SwaggerString
302281 & format ?~ "binary"
303282
304283-- | Default schema for binary data (base64 encoded).
305284byteSchema :: Schema
306285byteSchema = mempty
307− & type_ ?~ SwaggerString
286+ & type_ .~ SwaggerString
308287 & format ?~ "byte"
309288
310289-- | Default schema for password string.
311290-- @"password"@ format is used to hint UIs the input needs to be obscured.
312291passwordSchema :: Schema
313292passwordSchema = mempty
314− & type_ ?~ SwaggerString
293+ & type_ .~ SwaggerString
315294 & format ?~ "password"
316295
317296-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -337,12 +316,12 @@ sketchSchema = sketch . toJSON
337316 sketch js@(Bool _) = go js
338317 sketch js = go js & example ?~ js
339318
340− go Null = mempty & type_ ?~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
344− go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
319+ go Null = mempty & type_ .~ SwaggerNull
320+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
321+ go js@(String s) = mempty & type_ .~ SwaggerString
322+ go js@(Number n) = mempty & type_ .~ SwaggerNumber
323+ go js@(Array xs) = mempty
324+ & type_ .~ SwaggerArray
346325 & items ?~ case ischema of
347326 Just s -> SwaggerItemsObject (Inline s)
348327 _ -> SwaggerItemsArray (map Inline ys)
@@ -351,10 +330,10 @@ sketchSchema = sketch . toJSON
351330 allSame = and ((zipWith (==)) ys (tail ys))
352331
353332 ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
333+ (z:zs) | allSame -> Just z
334+ _ -> Nothing
335+ go js@(Object o) = mempty
336+ & type_ .~ SwaggerObject
358337 & required .~ HashMap.keys o
359338 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360339
@@ -377,24 +356,24 @@ sketchSchema = sketch . toJSON
377356sketchStrictSchema :: ToJSON a => a -> Schema
378357sketchStrictSchema = go . toJSON
379358 where
380− go Null = mempty & type_ ?~ SwaggerNull
359+ go Null = mempty & type_ .~ SwaggerNull
381360 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
361+ & type_ .~ SwaggerBoolean
383362 & enum_ ?~ [js]
384363 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
364+ & type_ .~ SwaggerString
386365 & maxLength ?~ fromIntegral (T.length s)
387366 & minLength ?~ fromIntegral (T.length s)
388367 & pattern ?~ s
389368 & enum_ ?~ [js]
390369 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
370+ & type_ .~ SwaggerNumber
392371 & maximum_ ?~ n
393372 & minimum_ ?~ n
394373 & multipleOf ?~ n
395374 & enum_ ?~ [js]
396375 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
376+ & type_ .~ SwaggerArray
398377 & maxItems ?~ fromIntegral sz
399378 & minItems ?~ fromIntegral sz
400379 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,7 +383,7 @@ sketchStrictSchema = go . toJSON
404383 sz = length xs
405384 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406385 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
386+ & type_ .~ SwaggerObject
408387 & required .~ names
409388 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410389 & maxProperties ?~ fromIntegral (length names)
@@ -414,19 +393,18 @@ sketchStrictSchema = go . toJSON
414393 names = HashMap.keys o
415394
416395class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
396+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418397
419398instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420399 declareNamedSchema _ = do
421400 ref <- declareSchemaRef (Proxy :: Proxy a)
422401 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
402+ & type_ .~ SwaggerArray
424403 & items ?~ SwaggerItemsObject ref
425404
426405instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427406instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428407instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430408instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431409instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432410instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -438,16 +416,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438416instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439417instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440418
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
419+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
445420instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446421instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447422instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448423
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451424instance ToSchema a => ToSchema (Maybe a) where
452425 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453426
@@ -456,11 +429,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
456429instance ToSchema () where
457430 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458431
459−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
460−instance ToSchema UUID.UUID where
461− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
462− & example ?~ toJSON (UUID.toText UUID.nil)
463−
464432instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465433instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466434instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -470,81 +438,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470438
471439timeSchema :: T.Text -> Schema
472440timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
441+ & type_ .~ SwaggerString
474442 & format ?~ fmt
475443
476444-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477445instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479− & example ?~ toJSON (fromGregorian 2016 7 22)
446+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
480447
481448-- |
482449-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483450-- Just "yyyy-mm-ddThh:MM:ss"
484451instance ToSchema LocalTime where
485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
452+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
487453
488454-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489455instance ToSchema ZonedTime where
490456 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492457
493458instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
459+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495460
496461-- |
497462-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498463-- Just "yyyy-mm-ddThh:MM:ssZ"
499464instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
465+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
502466
503467instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504468instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505469
506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507−
508−#if __GLASGOW_HASKELL__ < 800
509−#else
510−type family ToSchemaByteStringError bs where
511− ToSchemaByteStringError bs = TypeError
512− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
513− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
514− :$$: Text "Consider using byteSchema or binarySchema templates." )
515−
516−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"
517−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"
518−#endif
519−
520470instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521471
522472-- | NOTE: This schema does not account for the uniqueness of keys.
523473instance ToSchema a => ToSchema (IntMap a) where
524474 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525475
526−#if MIN_VERSION_aeson(1,0,0)
527−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
528− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
529− ToJSONKeyText _ _ -> declareObjectMapSchema
530− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
531− where
532− declareObjectMapSchema = do
533− schema <- declareSchemaRef (Proxy :: Proxy v)
534− return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
537−
538−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
540−
541−#else
542−
543476instance ToSchema a => ToSchema (Map String a) where
544477 declareNamedSchema _ = do
545478 schema <- declareSchemaRef (Proxy :: Proxy a)
546479 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
480+ & type_ .~ SwaggerObject
548481 & additionalProperties ?~ schema
549482
550483instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -554,14 +487,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =
554487instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555488instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556489
557−#endif
558−
559−instance OVERLAPPING_ ToSchema Object where
560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
561− & type_ ?~ SwaggerObject
562− & description ?~ "Arbitrary JSON object."
563− & additionalProperties ?~ AdditionalPropertiesAllowed True
564−
565490instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566491instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567492instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +500,6 @@ instance ToSchema a => ToSchema (Set a) where
575500
576501instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577502
578−-- | @since 2.2.1
579−instance ToSchema a => ToSchema (NonEmpty a) where
580− declareNamedSchema _ = do
581− schema <- declareSchema (Proxy :: Proxy [a])
582− return $ unnamed $ schema
583− & minItems .~ Just 1
584−
585503instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586504instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587505
@@ -591,141 +509,61 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591509instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592510instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593511
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596512-- | Default schema for @'Bounded'@, @'Integral'@ types.
597513--
598514-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599515-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
516+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601517toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
518+ & type_ .~ SwaggerInteger
603519 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604520 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605521
606522-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
523+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608524 ( Bounded a, Integral a
609525 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
526+ => SchemaOptions -> proxy a -> NamedSchema
611527genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613−
614−-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617− => SchemaOptions -- ^ How to derive the name.
618− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
620− -> Declare (Definitions Schema) NamedSchema
621−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622−
623−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624−-- This makes a much more useful schema when there aren't many options for key values.
625−--
626−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627−-- >>> instance ToJSON ButtonState
628−-- >>> instance ToSchema ButtonState
629−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630−-- >>> type ImageUrl = T.Text
631−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633−--
634−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
637− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
639−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640− ToJSONKeyText keyToText _ -> objectSchema keyToText
641− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642− where
643− objectSchema keyToText = do
644− valueRef <- declareSchemaRef (Proxy :: Proxy value)
645− let allKeys = [minBound..maxBound :: key]
646− mkPair k = (keyToText k, valueRef)
647− return $ mempty
648− & type_ ?~ SwaggerObject
649− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650−
651−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652−-- This makes a much more useful schema when there aren't many options for key values.
653−--
654−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655−-- >>> instance ToJSON ButtonState
656−-- >>> instance ToSchema ButtonState
657−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658−-- >>> type ImageUrl = T.Text
659−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661−--
662−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
665− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
667−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
528+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
668529
669530-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
531+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
532+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673533
674534-- | A configurable generic @'NamedSchema'@ creator.
675535-- This function applied to @'defaultSchemaOptions'@
676536-- is used as the default for @'declareNamedSchema'@
677537-- 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
681−
682−-- | A configurable generic @'Schema'@ creator.
683−--
684−-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688−
689−-- | A configurable generic @'NamedSchema'@ creator.
690−--
691−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696−
697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
699− (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
538+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
539+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
702540
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
541+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
542+gdatatypeSchemaName opts _ = case name of
705543 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706544 _ -> Nothing
707545 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
546+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
710547
711548-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713− SchemaOptions -> Proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
549+paramSchemaToNamedSchema :: forall a d f proxy.
550+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
551+ => SchemaOptions -> proxy a -> NamedSchema
552+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715553
716554-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
555+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
556+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719557
720558nullarySchema :: Schema
721559nullarySchema = mempty
722− & type_ ?~ SwaggerArray
560+ & type_ .~ SwaggerArray
723561 & items ?~ SwaggerItemsArray []
724562
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
563+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726564gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727565
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
566+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729567gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730568
731569instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -745,7 +583,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745583 gdeclareNamedSchema = gdeclareNamedSumSchema
746584
747585-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
586+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749587 gdeclareNamedSchema opts _ s
750588 | unwrapUnaryRecords opts = fieldSchema
751589 | otherwise =
@@ -759,7 +597,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759597 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760598 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761599
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
600+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763601gdeclareSchemaRef opts proxy = do
764602 case gtoNamedSchema opts proxy of
765603 NamedSchema (Just name) schema -> do
@@ -778,7 +616,7 @@ gdeclareSchemaRef opts proxy = do
778616 return $ Ref (Reference name)
779617 _ -> Inline <$> gdeclareSchema opts proxy
780618
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
619+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
782620appendItem x Nothing = Just (SwaggerItemsArray [x])
783621appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
784622appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
@@ -790,12 +628,10 @@ withFieldSchema opts _ isRequiredField schema = do
790628 return $
791629 if T.null fname
792630 then schema
793− & type_ ?~ SwaggerArray
631+ & type_ .~ SwaggerArray
794632 & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797633 else schema
798− & type_ ?~ SwaggerObject
634+ & type_ .~ SwaggerObject
799635 & properties . at fname ?~ ref
800636 & if isRequiredField
801637 then required %~ (++ [fname])
@@ -817,13 +653,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
817653instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818654 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819655
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
656+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
824657 gdeclareNamedSchema = gdeclareNamedSumSchema
825658
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
659+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827660gdeclareNamedSumSchema opts proxy s
828661 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829662 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +665,29 @@ gdeclareNamedSumSchema opts proxy s
832665 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833666
834667 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
668+ & type_ .~ SwaggerString
836669 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837670
838671type AllNullary = All
839672
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
673+class GSumToSchema f where
674+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842675
843676instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844677 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845678
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
679+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
680+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848681gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
682+ & type_ .~ SwaggerObject
850683 & properties . at tag ?~ ref
851684 & maxProperties ?~ 1
852685 & minProperties ?~ 1
853686 where
854687 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855688
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
689+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
690+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858691gsumConToSchema opts proxy schema = do
859692 ref <- gdeclareSchemaRef opts proxy
860693 return $ gsumConToSchemaWith ref opts proxy schema
@@ -876,7 +709,3 @@ data Proxy2 a b = Proxy2
876709
877710data Proxy3 a b c = Proxy3
878711
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)