{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- For TypeErrors
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Data.Swagger.Internal.Schema where

import Prelude ()
import Prelude.Compat

import Control.Lens
import Data.Data.Lens (template)

import Control.Monad
import Control.Monad.Writer hiding (First, Last)
import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
import Data.Char
import Data.Data (Data)
import Data.Foldable (traverse_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           "unordered-containers" Data.HashSet (HashSet)
import qualified "unordered-containers" Data.HashSet as HashSet
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Int
import Data.IntSet (IntSet)
import Data.IntMap (IntMap)
import Data.List.NonEmpty.Compat (NonEmpty)
import Data.Map (Map)
import Data.Proxy
import Data.Scientific (Scientific)
import Data.Fixed (Fixed, HasResolution, Pico)
import Data.Set (Set)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import qualified Data.Vector as V
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import Data.Version (Version)
import Numeric.Natural.Compat (Natural)
import Data.Word
import GHC.Generics
import qualified Data.UUID.Types as UUID

import Data.Swagger.Declare
import Data.Swagger.Internal
import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
import Data.Swagger.Lens hiding (name, schema)
import qualified Data.Swagger.Lens as Swagger
import Data.Swagger.SchemaOptions
import Data.Swagger.Internal.TypeShape

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import GHC.TypeLits (TypeError, ErrorMessage(..))
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Key (toText)

unnamed :: Schema -> NamedSchema
unnamed :: Schema -> NamedSchema
unnamed Schema
schema = Maybe Text -> Schema -> NamedSchema
NamedSchema forall a. Maybe a
Nothing Schema
schema

named :: T.Text -> Schema -> NamedSchema
named :: Text -> Schema -> NamedSchema
named Text
name Schema
schema = Maybe Text -> Schema -> NamedSchema
NamedSchema (forall a. a -> Maybe a
Just Text
name) Schema
schema

plain :: Schema -> Declare (Definitions Schema) NamedSchema
plain :: Schema -> Declare (Definitions Schema) NamedSchema
plain = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> NamedSchema
unnamed

unname :: NamedSchema -> NamedSchema
unname :: NamedSchema -> NamedSchema
unname (NamedSchema Maybe Text
_ Schema
schema) = Schema -> NamedSchema
unnamed Schema
schema

rename :: Maybe T.Text -> NamedSchema -> NamedSchema
rename :: Maybe Text -> NamedSchema -> NamedSchema
rename Maybe Text
name (NamedSchema Maybe Text
_ Schema
schema) = Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
name Schema
schema

-- | Convert a type into @'Schema'@.
--
-- An example type and instance:
--
-- @
-- {-\# LANGUAGE OverloadedStrings \#-}   -- allows to write 'T.Text' literals
-- {-\# LANGUAGE OverloadedLists \#-}     -- allows to write 'Map' and 'HashMap' as lists
--
-- import Control.Lens
-- import Data.Proxy
-- import Data.Swagger
--
-- data Coord = Coord { x :: Double, y :: Double }
--
-- instance ToSchema Coord where
--   declareNamedSchema _ = do
--     doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
--     return $ NamedSchema (Just \"Coord\") $ mempty
--       & type_ ?~ SwaggerObject
--       & properties .~
--           [ (\"x\", doubleSchema)
--           , (\"y\", doubleSchema)
--           ]
--       & required .~ [ \"x\", \"y\" ]
-- @
--
-- Instead of manually writing your @'ToSchema'@ instance you can
-- use a default generic implementation of @'declareNamedSchema'@.
--
-- To do that, simply add @deriving 'Generic'@ clause to your datatype
-- and declare a @'ToSchema'@ instance for your datatype without
-- giving definition for @'declareNamedSchema'@.
--
-- For instance, the previous example can be simplified into this:
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import GHC.Generics (Generic)
--
-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
--
-- instance ToSchema Coord
-- @
class ToSchema a where
  -- | Convert a type into an optionally named schema
  -- together with all used definitions.
  -- Note that the schema itself is included in definitions
  -- only if it is recursive (and thus needs its definition in scope).
  declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
  default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
    Proxy a -> Declare (Definitions Schema) NamedSchema
  declareNamedSchema = forall a.
(Generic a, GToSchema (Rep a),
 TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions

instance ToSchema TimeOfDay where
  declareNamedSchema :: Proxy TimeOfDay -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy TimeOfDay
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"TimeOfDay" forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"hh:MM:ss"
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
12 Int
33 Pico
15)

-- | Convert a type into a schema and declare all used schema definitions.
declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
declareSchema :: forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> Schema
_namedSchemaSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema

-- | Convert a type into an optionally named schema.
--
-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
-- Nothing
-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
-- "{\"type\":\"string\"}"
--
-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
-- Just "Day"
-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
toNamedSchema :: forall a. ToSchema a => Proxy a -> NamedSchema
toNamedSchema = forall d a. Monoid d => Declare d a -> a
undeclare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema

-- | Get type's schema name according to its @'ToSchema'@ instance.
--
-- >>> schemaName (Proxy :: Proxy Int)
-- Nothing
--
-- >>> schemaName (Proxy :: Proxy UTCTime)
-- Just "UTCTime"
schemaName :: ToSchema a => Proxy a -> Maybe T.Text
schemaName :: forall a. ToSchema a => Proxy a -> Maybe Text
schemaName = NamedSchema -> Maybe Text
_namedSchemaName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToSchema a => Proxy a -> NamedSchema
toNamedSchema

-- | Convert a type into a schema.
--
-- >>> encode $ toSchema (Proxy :: Proxy Int8)
-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
--
-- >>> encode $ toSchema (Proxy :: Proxy [Day])
-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
toSchema :: ToSchema a => Proxy a -> Schema
toSchema :: forall a. ToSchema a => Proxy a -> Schema
toSchema = NamedSchema -> Schema
_namedSchemaSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToSchema a => Proxy a -> NamedSchema
toNamedSchema

-- | Convert a type into a referenced schema if possible.
-- Only named schemas can be referenced, nameless schemas are inlined.
--
-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
-- "{\"type\":\"integer\"}"
--
-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
-- "{\"$ref\":\"#/definitions/Day\"}"
toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
toSchemaRef :: forall a. ToSchema a => Proxy a -> Referenced Schema
toSchemaRef = forall d a. Monoid d => Declare d a -> a
undeclare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef

-- | Convert a type into a referenced schema if possible
-- and declare all used schema definitions.
-- Only named schemas can be referenced, nameless schemas are inlined.
--
-- Schema definitions are typically declared for every referenced schema.
-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
-- will be declared (regardless of whether it is recusive or not).
declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef :: forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef Proxy a
proxy = do
  case forall a. ToSchema a => Proxy a -> NamedSchema
toNamedSchema Proxy a
proxy of
    NamedSchema (Just Text
name) Schema
schema -> do
      -- This check is very important as it allows generically
      -- derive used definitions for recursive schemas.
      -- Lazy Declare monad allows toNamedSchema to ignore
      -- any declarations (which would otherwise loop) and
      -- retrieve the schema and its name to check if we
      -- have already declared it.
      -- If we have, we don't need to declare anything for
      -- this schema this time and thus simply return the reference.
      Bool
known <- forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (forall k a. (Eq k, Hashable k) => k -> InsOrdHashMap k a -> Bool
InsOrdHashMap.member Text
name)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
known) forall a b. (a -> b) -> a -> b
$ do
        forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [(Text
name, Schema
schema)]
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy a
proxy
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Reference -> Referenced a
Ref (Text -> Reference
Reference Text
name)
    NamedSchema
_ -> forall a. a -> Referenced a
Inline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema Proxy a
proxy

-- | Inline any referenced schema if its name satisfies given predicate.
--
-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
-- and schema stays referenced.
--
-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
inlineSchemasWhen :: forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen Text -> Bool
p Definitions Schema
defs = forall s a. (Data s, Typeable a) => Traversal' s a
template forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Referenced Schema -> Referenced Schema
deref
  where
    deref :: Referenced Schema -> Referenced Schema
deref r :: Referenced Schema
r@(Ref (Reference Text
name))
      | Text -> Bool
p Text
name =
          case forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
name Definitions Schema
defs of
            Just Schema
schema -> forall a. a -> Referenced a
Inline (forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen Text -> Bool
p Definitions Schema
defs Schema
schema)
            Maybe Schema
Nothing -> Referenced Schema
r
      | Bool
otherwise = Referenced Schema
r
    deref (Inline Schema
schema) = forall a. a -> Referenced a
Inline (forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen Text -> Bool
p Definitions Schema
defs Schema
schema)

-- | Inline any referenced schema if its name is in the given list.
--
-- /NOTE:/ if a referenced schema is not found in definitions
-- it stays referenced even if it appears in the list of names.
--
-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
inlineSchemas :: forall s. Data s => [Text] -> Definitions Schema -> s -> s
inlineSchemas [Text]
names = forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
names)

-- | Inline all schema references for which the definition
-- can be found in @'Definitions'@.
--
-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
inlineAllSchemas :: forall s. Data s => Definitions Schema -> s -> s
inlineAllSchemas = forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen (forall a b. a -> b -> a
const Bool
True)

-- | Convert a type into a schema without references.
--
-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
--
-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
-- when inlining recursive schemas.
toInlinedSchema :: ToSchema a => Proxy a -> Schema
toInlinedSchema :: forall a. ToSchema a => Proxy a -> Schema
toInlinedSchema Proxy a
proxy = forall s. Data s => Definitions Schema -> s -> s
inlineAllSchemas Definitions Schema
defs Schema
schema
  where
    (Definitions Schema
defs, Schema
schema) = forall d a. Declare d a -> d -> (d, a)
runDeclare (forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema Proxy a
proxy) forall a. Monoid a => a
mempty

-- | Inline all /non-recursive/ schemas for which the definition
-- can be found in @'Definitions'@.
inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
inlineNonRecursiveSchemas :: forall s. Data s => Definitions Schema -> s -> s
inlineNonRecursiveSchemas Definitions Schema
defs = forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen Text -> Bool
nonRecursive Definitions Schema
defs
  where
    nonRecursive :: Text -> Bool
nonRecursive Text
name =
      case forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
name Definitions Schema
defs of
        Just Schema
schema -> Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall d a. Declare d a -> d -> d
execDeclare (Schema -> DeclareT [Text] Identity ()
usedNames Schema
schema) forall a. Monoid a => a
mempty
        Maybe Schema
Nothing     -> Bool
False

    usedNames :: Schema -> DeclareT [Text] Identity ()
usedNames Schema
schema = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Referenced Schema -> DeclareT [Text] Identity ()
schemaRefNames (Schema
schema forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s a. (Data s, Typeable a) => Traversal' s a
template)

    schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
    schemaRefNames :: Referenced Schema -> DeclareT [Text] Identity ()
schemaRefNames Referenced Schema
ref = case Referenced Schema
ref of
      Ref (Reference Text
name) -> do
        Bool
seen <- forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
seen) forall a b. (a -> b) -> a -> b
$ do
          forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [Text
name]
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Schema -> DeclareT [Text] Identity ()
usedNames (forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
name Definitions Schema
defs)
      Inline Schema
subschema -> Schema -> DeclareT [Text] Identity ()
usedNames Schema
subschema

-- | Default schema for binary data (any sequence of octets).
binarySchema :: Schema
binarySchema :: Schema
binarySchema = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
  forall a b. a -> (a -> b) -> b
& forall s a. HasFormat s a => Lens' s a
format forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"binary"

-- | Default schema for binary data (base64 encoded).
byteSchema :: Schema
byteSchema :: Schema
byteSchema = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
  forall a b. a -> (a -> b) -> b
& forall s a. HasFormat s a => Lens' s a
format forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"byte"

-- | Default schema for password string.
-- @"password"@ format is used to hint UIs the input needs to be obscured.
passwordSchema :: Schema
passwordSchema :: Schema
passwordSchema = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
  forall a b. a -> (a -> b) -> b
& forall s a. HasFormat s a => Lens' s a
format forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"password"

-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema can be used for further refinement.
--
-- >>> encode $ sketchSchema "hello"
-- "{\"example\":\"hello\",\"type\":\"string\"}"
--
-- >>> encode $ sketchSchema (1, 2, 3)
-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
--
-- >>> encode $ sketchSchema ("Jack", 25)
-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
#if MIN_VERSION_text(2,0,0)
-- >>> encode $ sketchSchema (Person "Jack" 25)
-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
#else
-- >>> encode $ sketchSchema (Person "Jack" 25)
-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
#endif
sketchSchema :: ToJSON a => a -> Schema
sketchSchema :: forall a. ToJSON a => a -> Schema
sketchSchema = Value -> Schema
sketch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON
  where
    sketch :: Value -> Schema
sketch Value
Null = Value -> Schema
go Value
Null
    sketch js :: Value
js@(Bool Bool
_) = Value -> Schema
go Value
js
    sketch Value
js = Value -> Schema
go Value
js forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
js

    go :: Value -> Schema
go Value
Null       = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerNull
    go (Bool Bool
_)   = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerBoolean
    go (String Text
_) = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
    go (Number Scientific
_) = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerNumber
    go (Array Array
xs) = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_   forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerArray
      forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
items forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ case Maybe Schema
ischema of
          Just Schema
s -> Referenced Schema -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsObject (forall a. a -> Referenced a
Inline Schema
s)
          Maybe Schema
_      -> [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsArray (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Referenced a
Inline [Schema]
ys)
      where
        ys :: [Schema]
ys = forall a b. (a -> b) -> [a] -> [b]
map Value -> Schema
go (forall a. Vector a -> [a]
V.toList Array
xs)
        allSame :: Bool
allSame = forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==)) [Schema]
ys (forall a. [a] -> [a]
tail [Schema]
ys))

        ischema :: Maybe Schema
ischema = case [Schema]
ys of
          (Schema
z:[Schema]
_) | Bool
allSame -> forall a. a -> Maybe a
Just Schema
z
          [Schema]
_               -> forall a. Maybe a
Nothing
    go (Object Object
o') = let o :: HashMap Text Value
o = forall v. KeyMap v -> HashMap Text v
KM.toHashMapText Object
o' in forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_         forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required      forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k v. HashMap k v -> [k]
HashMap.keys HashMap Text Value
o
      forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties    forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Referenced a
Inline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Schema
go) (forall k v. HashMap k v -> InsOrdHashMap k v
InsOrdHashMap.fromHashMap HashMap Text Value
o)

-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema uses as much constraints as possible.
--
-- >>> encode $ sketchStrictSchema "hello"
-- "{\"enum\":[\"hello\"],\"maxLength\":5,\"minLength\":5,\"pattern\":\"hello\",\"type\":\"string\"}"
--
-- >>> encode $ sketchStrictSchema (1, 2, 3)
-- "{\"enum\":[[1,2,3]],\"items\":[{\"enum\":[1],\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\"},{\"enum\":[2],\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\"},{\"enum\":[3],\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\"}],\"maxItems\":3,\"minItems\":3,\"type\":\"array\",\"uniqueItems\":true}"
--
-- >>> encode $ sketchStrictSchema ("Jack", 25)
-- "{\"enum\":[[\"Jack\",25]],\"items\":[{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}],\"maxItems\":2,\"minItems\":2,\"type\":\"array\",\"uniqueItems\":true}"
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
#if MIN_VERSION_text(2,0,0)
-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"
#else
-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"
#endif
sketchStrictSchema :: ToJSON a => a -> Schema
sketchStrictSchema :: forall a. ToJSON a => a -> Schema
sketchStrictSchema = Value -> Schema
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON
  where
    go :: Value -> Schema
go Value
Null       = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerNull
    go js :: Value
js@(Bool Bool
_) = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerBoolean
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
js]
    go js :: Value
js@(String Text
s) = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
      forall a b. a -> (a -> b) -> b
& forall s a. HasMaxLength s a => Lens' s a
maxLength forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
s)
      forall a b. a -> (a -> b) -> b
& forall s a. HasMinLength s a => Lens' s a
minLength forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
s)
      forall a b. a -> (a -> b) -> b
& forall s a. HasPattern s a => Lens' s a
pattern   forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
s
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_     forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
js]
    go js :: Value
js@(Number Scientific
n) = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_       forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerNumber
      forall a b. a -> (a -> b) -> b
& forall s a. HasMaximum s a => Lens' s a
maximum_    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      forall a b. a -> (a -> b) -> b
& forall s a. HasMinimum s a => Lens' s a
minimum_    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      forall a b. a -> (a -> b) -> b
& forall s a. HasMultipleOf s a => Lens' s a
multipleOf  forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_       forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
js]
    go js :: Value
js@(Array Array
xs) = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_       forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerArray
      forall a b. a -> (a -> b) -> b
& forall s a. HasMaxItems s a => Lens' s a
maxItems    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
      forall a b. a -> (a -> b) -> b
& forall s a. HasMinItems s a => Lens' s a
minItems    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
      forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
items       forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsArray (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Referenced a
Inline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Schema
go) (forall a. Vector a -> [a]
V.toList Array
xs))
      forall a b. a -> (a -> b) -> b
& forall s a. HasUniqueItems s a => Lens' s a
uniqueItems forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
allUnique
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_       forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
js]
      where
        sz :: Int
sz = forall (t :: * -> *) a. Foldable t => t a -> Int
length Array
xs
        allUnique :: Bool
allUnique = Int
sz forall a. Eq a => a -> a -> Bool
== forall a. HashSet a -> Int
HashSet.size (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (forall a. Vector a -> [a]
V.toList Array
xs))
    go js :: Value
js@(Object Object
o') = let o :: HashMap Text Value
o = forall v. KeyMap v -> HashMap Text v
KM.toHashMapText Object
o' in forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_         forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required      forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text]
names
      forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties    forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Referenced a
Inline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Schema
go) (forall k v. HashMap k v -> InsOrdHashMap k v
InsOrdHashMap.fromHashMap HashMap Text Value
o)
      forall a b. a -> (a -> b) -> b
& forall s a. HasMaxProperties s a => Lens' s a
maxProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
names)
      forall a b. a -> (a -> b) -> b
& forall s a. HasMinProperties s a => Lens' s a
minProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
names)
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_         forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
js]
      where
        names :: [Text]
names = forall k v. HashMap k v -> [k]
HashMap.keys (forall v. KeyMap v -> HashMap Text v
KM.toHashMapText Object
o')

class GToSchema (f :: * -> *) where
  gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
  declareNamedSchema :: Proxy [a] -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy [a]
_ = do
    Referenced Schema
ref <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerArray
      forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
items forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsObject Referenced Schema
ref

instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema :: Proxy String -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Bool    where declareNamedSchema :: Proxy Bool -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Integer where declareNamedSchema :: Proxy Integer -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Natural where declareNamedSchema :: Proxy Natural -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Int     where declareNamedSchema :: Proxy Int -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Int8    where declareNamedSchema :: Proxy Int8 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Int16   where declareNamedSchema :: Proxy Int16 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Int32   where declareNamedSchema :: Proxy Int32 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Int64   where declareNamedSchema :: Proxy Int64 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Word    where declareNamedSchema :: Proxy Word -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Word8   where declareNamedSchema :: Proxy Word8 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Word16  where declareNamedSchema :: Proxy Word16 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Word32  where declareNamedSchema :: Proxy Word32 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Word64  where declareNamedSchema :: Proxy Word64 -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance ToSchema Char where
  declareNamedSchema :: Proxy Char -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Char
proxy = Schema -> Declare (Definitions Schema) NamedSchema
plain (forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy Char
proxy)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mappedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasSchema s a => Lens' s a
Swagger.schemaforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON Char
'?'

instance ToSchema Scientific  where declareNamedSchema :: Proxy Scientific -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Double      where declareNamedSchema :: Proxy Double -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Float       where declareNamedSchema :: Proxy Float -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema :: Proxy (Fixed a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance ToSchema a => ToSchema (Maybe a) where
  declareNamedSchema :: Proxy (Maybe a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Maybe a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance (ToSchema a, ToSchema b) => ToSchema (Either a b)

instance ToSchema () where
  declareNamedSchema :: Proxy () -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema forall a. Maybe a
Nothing Schema
nullarySchema)

-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
instance ToSchema UUID.UUID where
  declareNamedSchema :: Proxy UUID -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy UUID
p = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"UUID" forall a b. (a -> b) -> a -> b
$ forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy UUID
p
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (UUID -> Text
UUID.toText UUID
UUID.nil)

instance (ToSchema a, ToSchema b) => ToSchema (a, b)
instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)

timeSchema :: T.Text -> Schema
timeSchema :: Text -> Schema
timeSchema Text
fmt = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
  forall a b. a -> (a -> b) -> b
& forall s a. HasFormat s a => Lens' s a
format forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
fmt

-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
instance ToSchema Day where
  declareNamedSchema :: Proxy Day -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Day
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"Day" forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"date"
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (Integer -> Int -> Int -> Day
fromGregorian Integer
2016 Int
7 Int
22)

-- |
-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
-- Just "yyyy-mm-ddThh:MM:ss"
instance ToSchema LocalTime where
  declareNamedSchema :: Proxy LocalTime -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy LocalTime
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"LocalTime" forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"yyyy-mm-ddThh:MM:ss"
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2016 Int
7 Int
22) (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
7 Int
40 Pico
0))

-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
instance ToSchema ZonedTime where
  declareNamedSchema :: Proxy ZonedTime -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ZonedTime
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"ZonedTime" forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"date-time"
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2016 Int
7 Int
22) (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
7 Int
40 Pico
0)) (Int -> TimeZone
hoursToTimeZone Int
3))

instance ToSchema NominalDiffTime where
  declareNamedSchema :: Proxy NominalDiffTime -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy NominalDiffTime
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy Pico)

-- |
-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
-- Just "yyyy-mm-ddThh:MM:ssZ"
instance ToSchema UTCTime where
  declareNamedSchema :: Proxy UTCTime -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy UTCTime
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"UTCTime" forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"yyyy-mm-ddThh:MM:ssZ"
    forall a b. a -> (a -> b) -> b
& forall s a. HasExample s a => Lens' s a
example forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2016 Int
7 Int
22) DiffTime
0)

instance ToSchema T.Text where declareNamedSchema :: Proxy Text -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema TL.Text where declareNamedSchema :: Proxy Text -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance ToSchema Version where declareNamedSchema :: Proxy Version -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

type family ToSchemaByteStringError bs where
  ToSchemaByteStringError bs = TypeError
      ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
   :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
   :$$: Text "Consider using byteSchema or binarySchema templates." )

instance ToSchemaByteStringError BS.ByteString  => ToSchema BS.ByteString  where declareNamedSchema :: Proxy ByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall a. HasCallStack => String -> a
error String
"impossible"
instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema :: Proxy ByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall a. HasCallStack => String -> a
error String
"impossible"

instance ToSchema IntSet where declareNamedSchema :: Proxy IntSet -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy IntSet
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Set Int))

-- | NOTE: This schema does not account for the uniqueness of keys.
instance ToSchema a => ToSchema (IntMap a) where
  declareNamedSchema :: Proxy (IntMap a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (IntMap a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [(Int, a)])

instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
  declareNamedSchema :: Proxy (Map k v) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Map k v)
_ = case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey :: ToJSONKeyFunction k of
      ToJSONKeyText  k -> Key
_ k -> Encoding' Key
_ -> Declare (Definitions Schema) NamedSchema
declareObjectMapSchema
      ToJSONKeyValue k -> Value
_ k -> Encoding
_ -> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [(k, v)])
    where
      declareObjectMapSchema :: Declare (Definitions Schema) NamedSchema
declareObjectMapSchema = do
        Referenced Schema
schema <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall {k} (t :: k). Proxy t
Proxy :: Proxy v)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
          forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
          forall a b. a -> (a -> b) -> b
& forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> AdditionalProperties
AdditionalPropertiesSchema Referenced Schema
schema

instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
  declareNamedSchema :: Proxy (HashMap k v) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (HashMap k v)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Map k v))

instance {-# OVERLAPPING #-} ToSchema Object where
  declareNamedSchema :: Proxy Object -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Object
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (forall a. a -> Maybe a
Just Text
"Object") forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
    forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
    forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"Arbitrary JSON object."
    forall a b. a -> (a -> b) -> b
& forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool -> AdditionalProperties
AdditionalPropertiesAllowed Bool
True

instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema :: Proxy (Vector a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Vector a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema :: Proxy (Vector a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Vector a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema :: Proxy (Vector a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Vector a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema :: Proxy (Vector a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Vector a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])

instance ToSchema a => ToSchema (Set a) where
  declareNamedSchema :: Proxy (Set a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Set a)
_ = do
    Schema
schema <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed forall a b. (a -> b) -> a -> b
$ Schema
schema
      forall a b. a -> (a -> b) -> b
& forall s a. HasUniqueItems s a => Lens' s a
uniqueItems forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
True

instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema :: Proxy (HashSet a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (HashSet a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Set a))

-- | @since 2.2.1
instance ToSchema a => ToSchema (NonEmpty a) where
  declareNamedSchema :: Proxy (NonEmpty a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (NonEmpty a)
_ = do
    Schema
schema <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [a])
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed forall a b. (a -> b) -> a -> b
$ Schema
schema
      forall a b. a -> (a -> b) -> b
& forall s a. HasMinItems s a => Lens' s a
minItems forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just Integer
1

instance ToSchema All where declareNamedSchema :: Proxy All -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema
instance ToSchema Any where declareNamedSchema :: Proxy Any -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance ToSchema a => ToSchema (Sum a)     where declareNamedSchema :: Proxy (Sum a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Sum a)
_ = NamedSchema -> NamedSchema
unname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToSchema a => ToSchema (Product a) where declareNamedSchema :: Proxy (Product a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Product a)
_ = NamedSchema -> NamedSchema
unname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToSchema a => ToSchema (First a)   where declareNamedSchema :: Proxy (First a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (First a)
_ = NamedSchema -> NamedSchema
unname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToSchema a => ToSchema (Last a)    where declareNamedSchema :: Proxy (Last a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Last a)
_ = NamedSchema -> NamedSchema
unname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToSchema a => ToSchema (Dual a)    where declareNamedSchema :: Proxy (Dual a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Dual a)
_ = NamedSchema -> NamedSchema
unname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance ToSchema a => ToSchema (Identity a) where declareNamedSchema :: Proxy (Identity a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Identity a)
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | Default schema for @'Bounded'@, @'Integral'@ types.
--
-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral Proxy a
_ = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerInteger
  forall a b. a -> (a -> b) -> b
& forall s a. HasMinimum s a => Lens' s a
minimum_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. Num a => Integer -> a
fromInteger (forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound :: a))
  forall a b. a -> (a -> b) -> b
& forall s a. HasMaximum s a => Lens' s a
maximum_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. Num a => Integer -> a
fromInteger (forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: a))

-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
genericToNamedSchemaBoundedIntegral :: forall a d f.
  ( Bounded a, Integral a
  , Generic a, Rep a ~ D1 d f, Datatype d)
  => SchemaOptions -> Proxy a -> NamedSchema
genericToNamedSchemaBoundedIntegral :: forall a (d :: Meta) (f :: * -> *).
(Bounded a, Integral a, Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> NamedSchema
genericToNamedSchemaBoundedIntegral SchemaOptions
opts Proxy a
proxy
  = forall a (d :: Meta) (f :: * -> *).
(Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema SchemaOptions
opts Proxy a
proxy (forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral Proxy a
proxy)

-- | Declare a named schema for a @newtype@ wrapper.
genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
  (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
  => SchemaOptions                                          -- ^ How to derive the name.
  -> (Proxy inner -> Declare (Definitions Schema) Schema)   -- ^ How to create a schema for the wrapped type.
  -> Proxy a
  -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaNewtype :: forall a (d :: Meta) (c :: Meta) (s :: Meta) i inner.
(Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner)))) =>
SchemaOptions
-> (Proxy inner -> Declare (Definitions Schema) Schema)
-> Proxy a
-> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaNewtype SchemaOptions
opts Proxy inner -> Declare (Definitions Schema) Schema
f Proxy a
proxy = forall a (d :: Meta) (f :: * -> *).
(Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema SchemaOptions
opts Proxy a
proxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy inner -> Declare (Definitions Schema) Schema
f (forall {k} (t :: k). Proxy t
Proxy :: Proxy inner)

-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
-- This makes a much more useful schema when there aren't many options for key values.
--
-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
-- >>> instance ToJSON ButtonState
-- >>> instance ToSchema ButtonState
-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
-- >>> type ImageUrl = T.Text
-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
--
-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
declareSchemaBoundedEnumKeyMapping :: forall map key value.
  (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
  => Proxy (map key value) -> Declare (Definitions Schema) Schema
declareSchemaBoundedEnumKeyMapping :: forall {k} (map :: * -> * -> k) key value.
(Bounded key, Enum key, ToJSONKey key, ToSchema key,
 ToSchema value) =>
Proxy (map key value) -> Declare (Definitions Schema) Schema
declareSchemaBoundedEnumKeyMapping Proxy (map key value)
_ = case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey :: ToJSONKeyFunction key of
  ToJSONKeyText key -> Key
keyToText key -> Encoding' Key
_ -> (key -> Key) -> Declare (Definitions Schema) Schema
objectSchema key -> Key
keyToText
  ToJSONKeyValue key -> Value
_ key -> Encoding
_ -> forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy [(key, value)])
  where
    objectSchema :: (key -> Key) -> Declare (Definitions Schema) Schema
objectSchema key -> Key
keyToText = do
      Referenced Schema
valueRef <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall {k} (t :: k). Proxy t
Proxy :: Proxy value)
      let allKeys :: [key]
allKeys   = [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound :: key]
          mkPair :: key -> (Text, Referenced Schema)
mkPair key
k  = (Key -> Text
toText forall a b. (a -> b) -> a -> b
$ key -> Key
keyToText key
k, Referenced Schema
valueRef)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
        forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_      forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
        forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList (forall a b. (a -> b) -> [a] -> [b]
map key -> (Text, Referenced Schema)
mkPair [key]
allKeys)

-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
-- This makes a much more useful schema when there aren't many options for key values.
--
-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
-- >>> instance ToJSON ButtonState
-- >>> instance ToSchema ButtonState
-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
-- >>> type ImageUrl = T.Text
-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
--
-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
toSchemaBoundedEnumKeyMapping :: forall map key value.
  (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
  => Proxy (map key value) -> Schema
toSchemaBoundedEnumKeyMapping :: forall {k} (map :: * -> * -> k) key value.
(Bounded key, Enum key, ToJSONKey key, ToSchema key,
 ToSchema value) =>
Proxy (map key value) -> Schema
toSchemaBoundedEnumKeyMapping = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall d a. Declare d a -> d -> a
evalDeclare forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (map :: * -> * -> k) key value.
(Bounded key, Enum key, ToJSONKey key, ToSchema key,
 ToSchema value) =>
Proxy (map key value) -> Declare (Definitions Schema) Schema
declareSchemaBoundedEnumKeyMapping

-- | A configurable generic @'Schema'@ creator.
genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema :: forall a.
(Generic a, GToSchema (Rep a),
 TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema = forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchemaUnrestricted

-- | A configurable generic @'NamedSchema'@ creator.
-- This function applied to @'defaultSchemaOptions'@
-- is used as the default for @'declareNamedSchema'@
-- when the type is an instance of @'Generic'@.
genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema :: forall a.
(Generic a, GToSchema (Rep a),
 TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema = forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaUnrestricted

-- | A configurable generic @'Schema'@ creator.
--
-- Unlike 'genericDeclareSchema' also works for mixed sum types.
-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchemaUnrestricted :: forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchemaUnrestricted SchemaOptions
opts Proxy a
proxy = NamedSchema -> Schema
_namedSchemaSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaUnrestricted SchemaOptions
opts Proxy a
proxy

-- | A configurable generic @'NamedSchema'@ creator.
--
-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaUnrestricted :: forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaUnrestricted SchemaOptions
opts Proxy a
_ = forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep a)) forall a. Monoid a => a
mempty

-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
genericNameSchema :: forall a d f.
  (Generic a, Rep a ~ D1 d f, Datatype d)
  => SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema :: forall a (d :: Meta) (f :: * -> *).
(Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema SchemaOptions
opts Proxy a
_ = Maybe Text -> Schema -> NamedSchema
NamedSchema (forall {k} (d :: k).
Datatype d =>
SchemaOptions -> Proxy d -> Maybe Text
gdatatypeSchemaName SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))

gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
gdatatypeSchemaName :: forall {k} (d :: k).
Datatype d =>
SchemaOptions -> Proxy d -> Maybe Text
gdatatypeSchemaName SchemaOptions
opts Proxy d
_ = case String
orig of
  (Char
c:String
_) | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
c -> forall a. a -> Maybe a
Just (String -> Text
T.pack String
name)
  String
_ -> forall a. Maybe a
Nothing
  where
    orig :: String
orig = forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 d f a)
    name :: String
name = SchemaOptions -> String -> String
datatypeNameModifier SchemaOptions
opts String
orig

-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
  SchemaOptions -> Proxy a -> NamedSchema
paramSchemaToNamedSchema :: forall a (d :: Meta) (f :: * -> *).
(ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> NamedSchema
paramSchemaToNamedSchema SchemaOptions
opts Proxy a
proxy = forall a (d :: Meta) (f :: * -> *).
(Generic a, Rep a ~ D1 d f, Datatype d) =>
SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema SchemaOptions
opts Proxy a
proxy (forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy a
proxy)

-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema :: forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy a
proxy = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasParamSchema s a => Lens' s a
paramSchema forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a (t :: SwaggerKind (*)).
ToParamSchema a =>
Proxy a -> ParamSchema t
toParamSchema Proxy a
proxy

nullarySchema :: Schema
nullarySchema :: Schema
nullarySchema = forall a. Monoid a => a
mempty
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerArray
  forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
items forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsArray []

gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
gtoNamedSchema :: forall (f :: * -> *).
GToSchema f =>
SchemaOptions -> Proxy f -> NamedSchema
gtoNamedSchema SchemaOptions
opts Proxy f
proxy = forall d a. Monoid d => Declare d a -> a
undeclare forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy f
proxy forall a. Monoid a => a
mempty

gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema :: forall (f :: * -> *).
GToSchema f =>
SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema SchemaOptions
opts Proxy f
proxy = NamedSchema -> Schema
_namedSchemaSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy f
proxy forall a. Monoid a => a
mempty

instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (f :*: g)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (f :*: g)
_ Schema
schema = do
    NamedSchema Maybe Text
_ Schema
gschema <- forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f) Schema
schema
    forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy g) Schema
gschema

instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (D1 d f)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (D1 d f)
_ Schema
s = Maybe Text -> NamedSchema -> NamedSchema
rename Maybe Text
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f) Schema
s
    where
      name :: Maybe Text
name = forall {k} (d :: k).
Datatype d =>
SchemaOptions -> Proxy d -> Maybe Text
gdatatypeSchemaName SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (C1 c f)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (C1 c f)
_ = forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f)

instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (C1 c U1)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema

-- | Single field constructor.
instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (C1 c (S1 s f))
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
_ Schema
s
    | SchemaOptions -> Bool
unwrapUnaryRecords SchemaOptions
opts = Declare (Definitions Schema) NamedSchema
fieldSchema
    | Bool
otherwise =
        case Schema
schema forall s a. s -> Getting a s a -> a
^. forall s a. HasItems s a => Lens' s a
items of
          Just (SwaggerItemsArray [Item [Referenced Schema]
_]) -> Declare (Definitions Schema) NamedSchema
fieldSchema
          Maybe (SwaggerItems 'SwaggerKindSchema)
_ -> do
            forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare Definitions Schema
defs
            forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> NamedSchema
unnamed Schema
schema)
    where
      (Definitions Schema
defs, NamedSchema Maybe Text
_ Schema
schema) = forall d a. Declare d a -> d -> (d, a)
runDeclare Declare (Definitions Schema) NamedSchema
recordSchema forall a. Monoid a => a
mempty
      recordSchema :: Declare (Definitions Schema) NamedSchema
recordSchema = forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy (S1 s f)) Schema
s
      fieldSchema :: Declare (Definitions Schema) NamedSchema
fieldSchema  = forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f) Schema
s

gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef :: forall (a :: * -> *).
GToSchema a =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts Proxy a
proxy = do
  case forall (f :: * -> *).
GToSchema f =>
SchemaOptions -> Proxy f -> NamedSchema
gtoNamedSchema SchemaOptions
opts Proxy a
proxy of
    NamedSchema (Just Text
name) Schema
schema -> do
      -- This check is very important as it allows generically
      -- derive used definitions for recursive schemas.
      -- Lazy Declare monad allows toNamedSchema to ignore
      -- any declarations (which would otherwise loop) and
      -- retrieve the schema and its name to check if we
      -- have already declared it.
      -- If we have, we don't need to declare anything for
      -- this schema this time and thus simply return the reference.
      Bool
known <- forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (forall k a. (Eq k, Hashable k) => k -> InsOrdHashMap k a -> Bool
InsOrdHashMap.member Text
name)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
known) forall a b. (a -> b) -> a -> b
$ do
        forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [(Text
name, Schema
schema)]
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy a
proxy forall a. Monoid a => a
mempty
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Reference -> Referenced a
Ref (Text -> Reference
Reference Text
name)
    NamedSchema
_ -> forall a. a -> Referenced a
Inline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
GToSchema f =>
SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema SchemaOptions
opts Proxy a
proxy

appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
appendItem :: Referenced Schema
-> Maybe (SwaggerItems 'SwaggerKindSchema)
-> Maybe (SwaggerItems 'SwaggerKindSchema)
appendItem Referenced Schema
x Maybe (SwaggerItems 'SwaggerKindSchema)
Nothing = forall a. a -> Maybe a
Just ([Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsArray [Referenced Schema
x])
appendItem Referenced Schema
x (Just (SwaggerItemsArray [Referenced Schema]
xs)) = forall a. a -> Maybe a
Just ([Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
SwaggerItemsArray ([Referenced Schema]
xs forall a. [a] -> [a] -> [a]
++ [Referenced Schema
x]))
appendItem Referenced Schema
_ Maybe (SwaggerItems 'SwaggerKindSchema)
_ = forall a. HasCallStack => String -> a
error String
"GToSchema.appendItem: cannot append to SwaggerItemsObject"

withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
  SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
withFieldSchema :: forall {k} (proxy :: k -> (* -> *) -> *) (s :: k) (f :: * -> *).
(Selector s, GToSchema f) =>
SchemaOptions
-> proxy s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
withFieldSchema SchemaOptions
opts proxy s f
_ Bool
isRequiredField Schema
schema = do
  Referenced Schema
ref <- forall (a :: * -> *).
GToSchema a =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    if Text -> Bool
T.null Text
fname
      then Schema
schema
        forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerArray
        forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
items forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Referenced Schema
-> Maybe (SwaggerItems 'SwaggerKindSchema)
-> Maybe (SwaggerItems 'SwaggerKindSchema)
appendItem Referenced Schema
ref
        forall a b. a -> (a -> b) -> b
& forall s a. HasMaxItems s a => Lens' s a
maxItems forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 (forall a. Num a => a -> a -> a
+Integer
1)   -- increment maxItems
        forall a b. a -> (a -> b) -> b
& forall s a. HasMinItems s a => Lens' s a
minItems forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 (forall a. Num a => a -> a -> a
+Integer
1)   -- increment minItems
      else Schema
schema
        forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
        forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
fname forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref
        forall a b. a -> (a -> b) -> b
& if Bool
isRequiredField
            then forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ [Text
fname])
            else forall a. a -> a
id
  where
    fname :: Text
fname = String -> Text
T.pack (SchemaOptions -> String -> String
fieldLabelModifier SchemaOptions
opts (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 s f p)))

-- | Optional record fields.
instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (S1 s (K1 i (Maybe c)))
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (S1 s (K1 i (Maybe c)))
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> NamedSchema
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> (* -> *) -> *) (s :: k) (f :: * -> *).
(Selector s, GToSchema f) =>
SchemaOptions
-> proxy s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
withFieldSchema SchemaOptions
opts (forall {k} {k} (a :: k) (b :: k). Proxy2 a b
Proxy2 :: Proxy2 s (K1 i (Maybe c))) Bool
False

-- | Record fields.
instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (S1 s f)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (S1 s f)
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> NamedSchema
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> (* -> *) -> *) (s :: k) (f :: * -> *).
(Selector s, GToSchema f) =>
SchemaOptions
-> proxy s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
withFieldSchema SchemaOptions
opts (forall {k} {k} (a :: k) (b :: k). Proxy2 a b
Proxy2 :: Proxy2 s f) Bool
True

instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (K1 i (Maybe c))
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
_ Proxy (K1 i (Maybe c))
_ Schema
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy c)

instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (K1 i c)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
_ Proxy (K1 i c)
_ Schema
_ = forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy c)

instance ( GSumToSchema f
         , GSumToSchema g
         ) => GToSchema (f :+: g)
   where
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (f :+: g)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema

gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema :: forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema SchemaOptions
opts Proxy f
proxy Schema
s
  | SchemaOptions -> Bool
allNullaryToStringTag SchemaOptions
opts Bool -> Bool -> Bool
&& Bool
allNullary = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (forall {s} {f :: * -> *} {a} {a} {b} {t :: SwaggerKind (*)}.
(HasProperties s (f a), ToJSON a, HasEnum b (Maybe [Value]),
 HasType b (Maybe (SwaggerType t)), Monoid b,
 FoldableWithIndex a f) =>
s -> b
toStringTag Schema
sumSchema)
  | Bool
otherwise = (Schema -> NamedSchema
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT All (DeclareT (Definitions Schema) Identity) Schema
declareSumSchema
  where
    declareSumSchema :: WriterT All (DeclareT (Definitions Schema) Identity) Schema
declareSumSchema = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts Proxy f
proxy Schema
s
    (Schema
sumSchema, All Bool
allNullary) = forall d a. Monoid d => Declare d a -> a
undeclare (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT All (DeclareT (Definitions Schema) Identity) Schema
declareSumSchema)

    toStringTag :: s -> b
toStringTag s
schema = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall (t :: SwaggerKind (*)). SwaggerType t
SwaggerString
      forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
enum_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
toJSON  (s
schema forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s a. HasProperties s a => Lens' s a
propertiesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifoldedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall i (p :: * -> * -> *) (f :: * -> *) s.
(Indexable i p, Contravariant f, Functor f) =>
p i (f i) -> Indexed i s (f s)
asIndex)

type AllNullary = All

class GSumToSchema (f :: * -> *)  where
  gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
  gsumToSchema :: SchemaOptions
-> Proxy (f :+: g)
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts Proxy (f :+: g)
_ = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy g)

gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
  Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith :: forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Referenced Schema
-> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith Referenced Schema
ref SchemaOptions
opts Proxy (C1 c f)
_ Schema
schema = Schema
schema
  forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
SwaggerObject
  forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
tag forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref
  forall a b. a -> (a -> b) -> b
& forall s a. HasMaxProperties s a => Lens' s a
maxProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer
1
  forall a b. a -> (a -> b) -> b
& forall s a. HasMinProperties s a => Lens' s a
minProperties forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer
1
  where
    tag :: Text
tag = String -> Text
T.pack (SchemaOptions -> String -> String
constructorTagModifier SchemaOptions
opts (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 c f p)))

gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
  SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
gsumConToSchema :: forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
SchemaOptions
-> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
gsumConToSchema SchemaOptions
opts Proxy (C1 c f)
proxy Schema
schema = do
  Referenced Schema
ref <- forall (a :: * -> *).
GToSchema a =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts Proxy (C1 c f)
proxy
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Referenced Schema
-> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith Referenced Schema
ref SchemaOptions
opts Proxy (C1 c f)
proxy Schema
schema

instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
  gsumToSchema :: SchemaOptions
-> Proxy (C1 c f)
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts Proxy (C1 c f)
proxy Schema
schema = do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
SchemaOptions
-> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
gsumConToSchema SchemaOptions
opts Proxy (C1 c f)
proxy Schema
schema

instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
  gsumToSchema :: SchemaOptions
-> Proxy (C1 c (S1 s f))
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
proxy Schema
schema = do
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
SchemaOptions
-> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
gsumConToSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
proxy Schema
schema

instance Constructor c => GSumToSchema (C1 c U1) where
  gsumToSchema :: SchemaOptions
-> Proxy (C1 c U1)
-> Schema
-> WriterT All (DeclareT (Definitions Schema) Identity) Schema
gsumToSchema SchemaOptions
opts Proxy (C1 c U1)
proxy = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Referenced Schema
-> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith (forall a. a -> Referenced a
Inline Schema
nullarySchema) SchemaOptions
opts Proxy (C1 c U1)
proxy

data Proxy2 a b = Proxy2

data Proxy3 a b c = Proxy3

-- $setup
-- >>> import Data.Swagger
-- >>> import Data.Aeson (encode)
-- >>> import Data.Aeson.Types (toJSONKeyText)