@@ -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,8 +51,6 @@ 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
6456import qualified Data.UUID.Types as UUID
@@ -69,13 +61,9 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
6961import Data.Swagger.Lens hiding (name, schema)
7062import qualified Data.Swagger.Lens as Swagger
7163import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
7364
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(..))
65+#ifdef __DOCTEST__
66+import Data.Swagger.Lens (name, schema)
7967#endif
8068
8169unnamed :: Schema -> NamedSchema
@@ -102,16 +90,14 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
10290-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
10391--
10492-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
10793--
10894-- data Coord = Coord { x :: Double, y :: Double }
10995--
11096-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
97+-- declareNamedSchema = do
11298-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
99+-- return $ NamedSchema (Just \"Coord\")) $ mempty
100+-- & type_ .~ SwaggerObject
115101-- & properties .~
116102-- [ (\"x\", doubleSchema)
117103-- , (\"y\", doubleSchema)
@@ -142,17 +128,12 @@ class ToSchema a where
142128 -- together with all used definitions.
143129 -- Note that the schema itself is included in definitions
144130 -- 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
131+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
132+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148133 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149134
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154135-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
136+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156137declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157138
158139-- | Convert a type into an optionally named schema.
@@ -166,7 +147,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
166147-- Just "Day"
167148-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168149-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
150+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170151toNamedSchema = undeclare . declareNamedSchema
171152
172153-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +157,7 @@ toNamedSchema = undeclare . declareNamedSchema
176157--
177158-- >>> schemaName (Proxy :: Proxy UTCTime)
178159-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
160+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180161schemaName = _namedSchemaName . toNamedSchema
181162
182163-- | Convert a type into a schema.
@@ -186,7 +167,7 @@ schemaName = _namedSchemaName . toNamedSchema
186167--
187168-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188169-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
170+toSchema :: ToSchema a => proxy a -> Schema
190171toSchema = _namedSchemaSchema . toNamedSchema
191172
192173-- | Convert a type into a referenced schema if possible.
@@ -197,7 +178,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197178--
198179-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199180-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
181+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201182toSchemaRef = undeclare . declareSchemaRef
202183
203184-- | Convert a type into a referenced schema if possible
@@ -207,7 +188,7 @@ toSchemaRef = undeclare . declareSchemaRef
207188-- Schema definitions are typically declared for every referenced schema.
208189-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209190-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
191+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211192declareSchemaRef proxy = do
212193 case toNamedSchema proxy of
213194 NamedSchema (Just name) schema -> do
@@ -269,7 +250,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
269250--
270251-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271252-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
253+toInlinedSchema :: ToSchema a => proxy a -> Schema
273254toInlinedSchema proxy = inlineAllSchemas defs schema
274255 where
275256 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -298,20 +279,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
298279-- | Default schema for binary data (any sequence of octets).
299280binarySchema :: Schema
300281binarySchema = mempty
301− & type_ ?~ SwaggerString
282+ & type_ .~ SwaggerString
302283 & format ?~ "binary"
303284
304285-- | Default schema for binary data (base64 encoded).
305286byteSchema :: Schema
306287byteSchema = mempty
307− & type_ ?~ SwaggerString
288+ & type_ .~ SwaggerString
308289 & format ?~ "byte"
309290
310291-- | Default schema for password string.
311292-- @"password"@ format is used to hint UIs the input needs to be obscured.
312293passwordSchema :: Schema
313294passwordSchema = mempty
314− & type_ ?~ SwaggerString
295+ & type_ .~ SwaggerString
315296 & format ?~ "password"
316297
317298-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -337,12 +318,12 @@ sketchSchema = sketch . toJSON
337318 sketch js@(Bool _) = go js
338319 sketch js = go js & example ?~ js
339320
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
321+ go Null = mempty & type_ .~ SwaggerNull
322+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
323+ go js@(String s) = mempty & type_ .~ SwaggerString
324+ go js@(Number n) = mempty & type_ .~ SwaggerNumber
325+ go js@(Array xs) = mempty
326+ & type_ .~ SwaggerArray
346327 & items ?~ case ischema of
347328 Just s -> SwaggerItemsObject (Inline s)
348329 _ -> SwaggerItemsArray (map Inline ys)
@@ -351,10 +332,10 @@ sketchSchema = sketch . toJSON
351332 allSame = and ((zipWith (==)) ys (tail ys))
352333
353334 ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
335+ (z:zs) | allSame -> Just z
336+ _ -> Nothing
337+ go js@(Object o) = mempty
338+ & type_ .~ SwaggerObject
358339 & required .~ HashMap.keys o
359340 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360341
@@ -377,24 +358,24 @@ sketchSchema = sketch . toJSON
377358sketchStrictSchema :: ToJSON a => a -> Schema
378359sketchStrictSchema = go . toJSON
379360 where
380− go Null = mempty & type_ ?~ SwaggerNull
361+ go Null = mempty & type_ .~ SwaggerNull
381362 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
363+ & type_ .~ SwaggerBoolean
383364 & enum_ ?~ [js]
384365 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
366+ & type_ .~ SwaggerString
386367 & maxLength ?~ fromIntegral (T.length s)
387368 & minLength ?~ fromIntegral (T.length s)
388369 & pattern ?~ s
389370 & enum_ ?~ [js]
390371 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
372+ & type_ .~ SwaggerNumber
392373 & maximum_ ?~ n
393374 & minimum_ ?~ n
394375 & multipleOf ?~ n
395376 & enum_ ?~ [js]
396377 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
378+ & type_ .~ SwaggerArray
398379 & maxItems ?~ fromIntegral sz
399380 & minItems ?~ fromIntegral sz
400381 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,7 +385,7 @@ sketchStrictSchema = go . toJSON
404385 sz = length xs
405386 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406387 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
388+ & type_ .~ SwaggerObject
408389 & required .~ names
409390 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410391 & maxProperties ?~ fromIntegral (length names)
@@ -414,19 +395,18 @@ sketchStrictSchema = go . toJSON
414395 names = HashMap.keys o
415396
416397class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
398+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418399
419400instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420401 declareNamedSchema _ = do
421402 ref <- declareSchemaRef (Proxy :: Proxy a)
422403 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
404+ & type_ .~ SwaggerArray
424405 & items ?~ SwaggerItemsObject ref
425406
426407instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427408instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428409instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430410instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431411instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432412instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -446,8 +426,6 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
446426instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447427instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448428
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451429instance ToSchema a => ToSchema (Maybe a) where
452430 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453431
@@ -470,7 +448,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470448
471449timeSchema :: T.Text -> Schema
472450timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
451+ & type_ .~ SwaggerString
474452 & format ?~ fmt
475453
476454-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -491,7 +469,7 @@ instance ToSchema ZonedTime where
491469 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492470
493471instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
472+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495473
496474-- |
497475-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -503,20 +481,6 @@ instance ToSchema UTCTime where
503481instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504482instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505483
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−
520484instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521485
522486-- | NOTE: This schema does not account for the uniqueness of keys.
@@ -532,8 +496,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
532496 declareObjectMapSchema = do
533497 schema <- declareSchemaRef (Proxy :: Proxy v)
534498 return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
499+ & type_ .~ SwaggerObject
500+ & additionalProperties ?~ schema
537501
538502instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539503 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -544,7 +508,7 @@ instance ToSchema a => ToSchema (Map String a) where
544508 declareNamedSchema _ = do
545509 schema <- declareSchemaRef (Proxy :: Proxy a)
546510 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
511+ & type_ .~ SwaggerObject
548512 & additionalProperties ?~ schema
549513
550514instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -556,12 +520,6 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
556520
557521#endif
558522
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−
565523instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566524instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567525instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +533,6 @@ instance ToSchema a => ToSchema (Set a) where
575533
576534instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577535
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−
585536instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586537instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587538
@@ -591,141 +542,61 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591542instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592543instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593544
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596545-- | Default schema for @'Bounded'@, @'Integral'@ types.
597546--
598547-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599548-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
549+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601550toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
551+ & type_ .~ SwaggerInteger
603552 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604553 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605554
606555-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
556+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608557 ( Bounded a, Integral a
609558 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
559+ => SchemaOptions -> proxy a -> NamedSchema
611560genericToNamedSchemaBoundedIntegral 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
561+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
668562
669563-- | 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
564+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
565+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673566
674567-- | A configurable generic @'NamedSchema'@ creator.
675568-- This function applied to @'defaultSchemaOptions'@
676569-- is used as the default for @'declareNamedSchema'@
677570-- 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))
571+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
572+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
702573
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
574+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
575+gdatatypeSchemaName opts _ = case name of
705576 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706577 _ -> Nothing
707578 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
579+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
710580
711581-- | 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)
582+paramSchemaToNamedSchema :: forall a d f proxy.
583+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
584+ => SchemaOptions -> proxy a -> NamedSchema
585+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715586
716587-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
588+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
589+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719590
720591nullarySchema :: Schema
721592nullarySchema = mempty
722− & type_ ?~ SwaggerArray
593+ & type_ .~ SwaggerArray
723594 & items ?~ SwaggerItemsArray []
724595
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
596+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726597gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727598
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
599+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729600gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730601
731602instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -745,7 +616,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745616 gdeclareNamedSchema = gdeclareNamedSumSchema
746617
747618-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
619+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749620 gdeclareNamedSchema opts _ s
750621 | unwrapUnaryRecords opts = fieldSchema
751622 | otherwise =
@@ -759,7 +630,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759630 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760631 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761632
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
633+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763634gdeclareSchemaRef opts proxy = do
764635 case gtoNamedSchema opts proxy of
765636 NamedSchema (Just name) schema -> do
@@ -778,7 +649,7 @@ gdeclareSchemaRef opts proxy = do
778649 return $ Ref (Reference name)
779650 _ -> Inline <$> gdeclareSchema opts proxy
780651
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
652+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
782653appendItem x Nothing = Just (SwaggerItemsArray [x])
783654appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
784655appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
@@ -790,12 +661,10 @@ withFieldSchema opts _ isRequiredField schema = do
790661 return $
791662 if T.null fname
792663 then schema
793− & type_ ?~ SwaggerArray
664+ & type_ .~ SwaggerArray
794665 & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797666 else schema
798− & type_ ?~ SwaggerObject
667+ & type_ .~ SwaggerObject
799668 & properties . at fname ?~ ref
800669 & if isRequiredField
801670 then required %~ (++ [fname])
@@ -817,13 +686,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
817686instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818687 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819688
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
689+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
824690 gdeclareNamedSchema = gdeclareNamedSumSchema
825691
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
692+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827693gdeclareNamedSumSchema opts proxy s
828694 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829695 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +698,29 @@ gdeclareNamedSumSchema opts proxy s
832698 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833699
834700 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
701+ & type_ .~ SwaggerString
836702 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837703
838704type AllNullary = All
839705
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
706+class GSumToSchema f where
707+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842708
843709instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844710 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845711
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
712+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
713+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848714gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
715+ & type_ .~ SwaggerObject
850716 & properties . at tag ?~ ref
851717 & maxProperties ?~ 1
852718 & minProperties ?~ 1
853719 where
854720 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855721
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
722+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
723+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858724gsumConToSchema opts proxy schema = do
859725 ref <- gdeclareSchemaRef opts proxy
860726 return $ gsumConToSchemaWith ref opts proxy schema
@@ -876,7 +742,3 @@ data Proxy2 a b = Proxy2
876742
877743data Proxy3 a b c = Proxy3
878744
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)