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

import Prelude ()
import Prelude.Compat

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

import Control.Monad
import Control.Monad.Writer hiding (First, Last)
import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),
                   ToJSONKeyFunction (..), Value (..))
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 (sort)
import Data.List.NonEmpty.Compat (NonEmpty)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
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 Type.Reflection (Typeable, typeRep)

import           Data.OpenApi.Aeson.Compat         (keyToText, objectKeys, toInsOrdHashMap)
import           Data.OpenApi.Declare
import           Data.OpenApi.Internal
import           Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
import           Data.OpenApi.Internal.TypeShape
import           Data.OpenApi.Lens                 hiding (name, schema)
import qualified Data.OpenApi.Lens                 as Swagger
import           Data.OpenApi.SchemaOptions

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import GHC.TypeLits (TypeError, ErrorMessage(..))

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

-- $setup
-- >>> import Data.Aeson.Types (toJSONKeyText)
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
-- >>> import Data.OpenApi.Internal
-- >>> import Data.OpenApi.Internal.Utils (encodePretty)
-- >>> import Data.OpenApi.Lens (name, 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.OpenApi
--
-- data Coord = Coord { x :: Double, y :: Double }
--
-- instance ToSchema Coord where
--   declareNamedSchema _ = do
--     doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
--     return $ NamedSchema (Just \"Coord\") $ mempty
--       & type_ ?~ OpenApiObject
--       & 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 Typeable a => 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)) =>
    Proxy a -> Declare (Definitions Schema) NamedSchema
  declareNamedSchema = forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
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
-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy String) ^. schema)
-- {
--     "type": "string"
-- }
--
-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
-- Just "Day"
-- >>> BSL.putStrLn $ encodePretty (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.
--
-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8)
-- {
--     "maximum": 127,
--     "minimum": -128,
--     "type": "integer"
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day])
-- {
--     "items": {
--         "$ref": "#/components/schemas/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.
--
-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer)
-- {
--     "type": "integer"
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day)
-- {
--     "$ref": "#/components/schemas/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.
--
-- >>> BSL.putStrLn $ encodePretty $ 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

-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema can be used for further refinement.
--
-- >>> BSL.putStrLn $ encodePretty $ sketchSchema "hello"
-- {
--     "example": "hello",
--     "type": "string"
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (1, 2, 3)
-- {
--     "example": [
--         1,
--         2,
--         3
--     ],
--     "items": {
--         "type": "number"
--     },
--     "type": "array"
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ 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
-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25)
-- {
--     "example": {
--         "age": 25,
--         "name": "Jack"
--     },
--     "properties": {
--         "age": {
--             "type": "number"
--         },
--         "name": {
--             "type": "string"
--         }
--     },
--     "required": [
--         "age",
--         "name"
--     ],
--     "type": "object"
-- }
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
?~ OpenApiType
OpenApiNull
    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
?~ OpenApiType
OpenApiBoolean
    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
?~ OpenApiType
OpenApiString
    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
?~ OpenApiType
OpenApiNumber
    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
?~ OpenApiType
OpenApiArray
      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 -> OpenApiItems
OpenApiItemsObject (forall a. a -> Referenced a
Inline Schema
s)
          Maybe Schema
_      -> [Referenced Schema] -> OpenApiItems
OpenApiItemsArray (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) = 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
?~ OpenApiType
OpenApiObject
      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 a. Ord a => [a] -> [a]
sort (forall v. KeyMap v -> [Text]
objectKeys Object
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 v. KeyMap v -> InsOrdHashMap Text v
toInsOrdHashMap Object
o)

-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema uses as much constraints as possible.
--
-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema "hello"
-- {
--     "enum": [
--         "hello"
--     ],
--     "maxLength": 5,
--     "minLength": 5,
--     "pattern": "hello",
--     "type": "string"
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ 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
-- }
--
-- >>> BSL.putStrLn $ encodePretty $ 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
-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25)
-- {
--     "enum": [
--         {
--             "age": 25,
--             "name": "Jack"
--         }
--     ],
--     "maxProperties": 2,
--     "minProperties": 2,
--     "properties": {
--         "age": {
--             "enum": [
--                 25
--             ],
--             "maximum": 25,
--             "minimum": 25,
--             "multipleOf": 25,
--             "type": "number"
--         },
--         "name": {
--             "enum": [
--                 "Jack"
--             ],
--             "maxLength": 4,
--             "minLength": 4,
--             "pattern": "Jack",
--             "type": "string"
--         }
--     },
--     "required": [
--         "age",
--         "name"
--     ],
--     "type": "object"
-- }
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
?~ OpenApiType
OpenApiNull
    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
?~ OpenApiType
OpenApiBoolean
      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
?~ OpenApiType
OpenApiString
      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
?~ OpenApiType
OpenApiNumber
      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
?~ OpenApiType
OpenApiArray
      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] -> OpenApiItems
OpenApiItemsArray (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) = 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
?~ OpenApiType
OpenApiObject
      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 a. Ord a => [a] -> [a]
sort [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 v. KeyMap v -> InsOrdHashMap Text v
toInsOrdHashMap Object
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 v. KeyMap v -> [Text]
objectKeys 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
?~ OpenApiType
OpenApiArray
      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 -> OpenApiItems
OpenApiItemsObject 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 (Typeable (Fixed a), 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) where
  -- To match Aeson instance
  declareNamedSchema :: Proxy (Either a b) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
ObjectWithSingleField }

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) where
  declareNamedSchema :: Proxy (a, b) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions
instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
  declareNamedSchema :: Proxy (a, b, c) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
  declareNamedSchema :: Proxy (a, b, c, d) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
  declareNamedSchema :: Proxy (a, b, c, d, e) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
  declareNamedSchema :: Proxy (a, b, c, d, e, f)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
  declareNamedSchema :: Proxy (a, b, c, d, e, f, g)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> NamedSchema
unname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
defaultSchemaOptions

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
?~ OpenApiType
OpenApiString
  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-time"@ 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
?~ OpenApiType
OpenApiObject
          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
?~ OpenApiType
OpenApiObject
    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.
--
-- >>> BSL.putStrLn $ encodePretty $ 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
?~ OpenApiType
OpenApiInteger
  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
-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- {
--     "properties": {
--         "Active": {
--             "type": "string"
--         },
--         "Disabled": {
--             "type": "string"
--         },
--         "Focus": {
--             "type": "string"
--         },
--         "Hover": {
--             "type": "string"
--         },
--         "Neutral": {
--             "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
getKey key -> Encoding' Key
_ -> (key -> Key) -> Declare (Definitions Schema) Schema
objectSchema key -> Key
getKey
  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
getKey = 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
keyToText forall a b. (a -> b) -> a -> b
$ key -> Key
getKey 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
?~ OpenApiType
OpenApiObject
        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
-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- {
--     "properties": {
--         "Active": {
--             "type": "string"
--         },
--         "Disabled": {
--             "type": "string"
--         },
--         "Focus": {
--             "type": "string"
--         },
--         "Hover": {
--             "type": "string"
--         },
--         "Neutral": {
--             "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), Typeable a) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema :: forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema 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), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
opts Proxy a
proxy

-- | 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'@.
--
-- Default implementation will use the name from 'Typeable' instance, including concrete
-- instantioations of type variables.
--
-- For example:
--
-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
-- Just "Either_Int_Bool"
genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema :: forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
opts Proxy a
_ =
  Maybe Text -> NamedSchema -> NamedSchema
rename (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
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 (Rep a)) forall a. Monoid a => a
mempty
  where
    unspace :: Char -> Char
unspace Char
' ' = Char
'_'
    unspace Char
x = Char
x
    orig :: String
orig = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
unspace forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a
    name :: String
name = SchemaOptions -> String -> String
datatypeNameModifier SchemaOptions
opts String
orig


-- | 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

-- | Construct 'NamedSchema' usinng 'ToParamSchema'.
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)

-- | Construct 'Schema' usinng 'ToParamSchema'.
paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema :: forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema = forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema

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
?~ OpenApiType
OpenApiArray
  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] -> OpenApiItems
OpenApiItemsArray []

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 (OpenApiItemsArray [Item [Referenced Schema]
_]) -> Declare (Definitions Schema) NamedSchema
fieldSchema
          Maybe OpenApiItems
_ -> do
            -- We have to run recordSchema instead of just using its defs,
            -- since those can be recursive and will lead to infinite loop,
            -- see https://github.com/biocad/openapi3/pull/37
            NamedSchema Maybe Text
_ Schema
schema' <- Declare (Definitions Schema) NamedSchema
recordSchema
            forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> NamedSchema
unnamed Schema
schema')
    where
      (Definitions Schema
_, 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 OpenApiItems -> Maybe OpenApiItems
appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
appendItem Referenced Schema
x Maybe OpenApiItems
Nothing = forall a. a -> Maybe a
Just ([Referenced Schema] -> OpenApiItems
OpenApiItemsArray [Referenced Schema
x])
appendItem Referenced Schema
x (Just (OpenApiItemsArray [Referenced Schema]
xs)) = forall a. a -> Maybe a
Just ([Referenced Schema] -> OpenApiItems
OpenApiItemsArray ([Referenced Schema]
xs forall a. [a] -> [a] -> [a]
++ [Referenced Schema
x]))
appendItem Referenced Schema
_ Maybe OpenApiItems
_ = forall a. HasCallStack => String -> a
error String
"GToSchema.appendItem: cannot append to OpenApiItemsObject"

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
?~ OpenApiType
OpenApiArray
        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 OpenApiItems -> Maybe OpenApiItems
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
?~ OpenApiType
OpenApiObject
        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
  -- Aeson does not unwrap unary record in sum types.
  gdeclareNamedSchema :: SchemaOptions
-> Proxy (f :+: g)
-> Schema
-> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy (f :+: g)
p Schema
s = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema (SchemaOptions
opts { unwrapUnaryRecords :: Bool
unwrapUnaryRecords = Bool
False } )Proxy (f :+: g)
p Schema
s

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
_
  | 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 ([(Text, Referenced Schema)] -> Schema
toStringTag [(Text, Referenced Schema)]
sumSchemas)
  | Bool
otherwise = do
    ([(Text, Referenced Schema)]
schemas, All
_) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  All
  (DeclareT (Definitions Schema) Identity)
  [(Text, Referenced Schema)]
declareSumSchema
    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. HasOneOf s a => Lens' s a
oneOf forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Referenced Schema)]
schemas)
  where
    declareSumSchema :: WriterT
  All
  (DeclareT (Definitions Schema) Identity)
  [(Text, Referenced Schema)]
declareSumSchema = forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy f
proxy
    ([(Text, Referenced Schema)]
sumSchemas, 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)
  [(Text, Referenced Schema)]
declareSumSchema)

    toStringTag :: [(Text, Referenced Schema)] -> Schema
toStringTag [(Text, Referenced Schema)]
schemas = 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
?~ OpenApiType
OpenApiString
      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 (Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Referenced Schema)]
sumSchemas

type AllNullary = All

class GSumToSchema (f :: * -> *)  where
  gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]

instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
  gsumToSchema :: SchemaOptions
-> Proxy (f :+: g)
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (f :+: g)
_ =
    forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy f) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts (forall {k} (t :: k). Proxy t
Proxy :: Proxy g)

-- | Convert one component of the sum to schema, to be later combined with @oneOf@.
gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
  Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)
gsumConToSchemaWith :: forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Maybe (Referenced Schema)
-> SchemaOptions -> Proxy (C1 c f) -> (Text, Referenced Schema)
gsumConToSchemaWith Maybe (Referenced Schema)
ref SchemaOptions
opts Proxy (C1 c f)
_ = (Text
tag, Referenced Schema
schema)
  where
    schema :: Referenced Schema
schema = case SchemaOptions -> SumEncoding
sumEncoding SchemaOptions
opts of
      TaggedObject String
tagField String
contentsField ->
        case Maybe (Referenced Schema)
ref of
          -- If subschema is an object and constructor is a record, we add tag directly
          -- to the record, as Aeson does it.
          Just (Inline Schema
sub) | Schema
sub forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_ forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just OpenApiType
OpenApiObject Bool -> Bool -> Bool
&& Bool
isRecord -> forall a. a -> Referenced a
Inline forall a b. (a -> b) -> a -> b
$ Schema
sub
            forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [String -> Text
T.pack String
tagField]
            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 (String -> Text
T.pack String
tagField) forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiString 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
?~ [Text -> Value
String Text
tag])

          -- If it is not a record, we need to put subschema into "contents" field.
          Maybe (Referenced Schema)
_ | Bool -> Bool
not Bool
isRecord -> forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiObject
            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
.~ [String -> Text
T.pack String
tagField]
            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 (String -> Text
T.pack String
tagField) forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiString 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
?~ [Text -> Value
String Text
tag])
              -- If constructor is nullary, there is no content.
            forall a b. a -> (a -> b) -> b
& case Maybe (Referenced Schema)
ref of
                Just Referenced Schema
r -> (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 (String -> Text
T.pack String
contentsField) forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. HasRequired s a => Lens' s a
required forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [String -> Text
T.pack String
contentsField])
                Maybe (Referenced Schema)
Nothing -> forall a. a -> a
id

          -- In the remaining cases we combine "tag" object and "contents" object using allOf.
          Maybe (Referenced Schema)
_ -> forall a. a -> Referenced a
Inline forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
            forall a b. a -> (a -> b) -> b
& forall s a. HasAllOf s a => Lens' s a
allOf forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiObject
              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
.~ (String -> Text
T.pack String
tagField forall a. a -> [a] -> [a]
: if Bool
isRecord then [] else [String -> Text
T.pack String
contentsField])
              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 (String -> Text
T.pack String
tagField) forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiString 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
?~ [Text -> Value
String Text
tag])]
            forall a b. a -> (a -> b) -> b
& if Bool
isRecord
                 then forall s a. HasAllOf s a => Lens' s a
allOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Referenced Schema
refOrNullary]
                 else forall s a. HasAllOf s a => Lens' s a
allOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiObject 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 (String -> Text
T.pack String
contentsField) forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
refOrNullary]
      SumEncoding
UntaggedValue -> Referenced Schema
refOrEnum -- Aeson encodes nullary constructors as strings in this case.
      SumEncoding
ObjectWithSingleField -> forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiObject
        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
tag]
        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
refOrNullary
      SumEncoding
TwoElemArray -> forall a. HasCallStack => String -> a
error String
"unrepresentable in OpenAPI 3"

    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)))
    isRecord :: Bool
isRecord = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord (forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 c f p)
    refOrNullary :: Referenced Schema
refOrNullary = forall a. a -> Maybe a -> a
fromMaybe (forall a. a -> Referenced a
Inline Schema
nullarySchema) Maybe (Referenced Schema)
ref
    refOrEnum :: Referenced Schema
refOrEnum = forall a. a -> Maybe a -> a
fromMaybe (forall a. a -> Referenced a
Inline 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
?~ OpenApiType
OpenApiString 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
?~ [Text -> Value
String Text
tag]) Maybe (Referenced Schema)
ref

gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
  SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]
gsumConToSchema :: forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
SchemaOptions
-> Proxy (C1 c f)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
gsumConToSchema SchemaOptions
opts Proxy (C1 c f)
proxy = 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 (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Maybe (Referenced Schema)
-> SchemaOptions -> Proxy (C1 c f) -> (Text, Referenced Schema)
gsumConToSchemaWith (forall a. a -> Maybe a
Just Referenced Schema
ref) SchemaOptions
opts Proxy (C1 c f)
proxy]

instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
  gsumToSchema :: SchemaOptions
-> Proxy (C1 c f)
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (C1 c f)
proxy = 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)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
gsumConToSchema SchemaOptions
opts Proxy (C1 c f)
proxy

instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
  gsumToSchema :: SchemaOptions
-> Proxy (C1 c (S1 s f))
-> WriterT
     All
     (DeclareT (Definitions Schema) Identity)
     [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
proxy = 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)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
gsumConToSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
proxy

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

data Proxy2 a b = Proxy2

data Proxy3 a b c = Proxy3

{- $setup
>>> import Data.OpenApi
>>> import Data.Aeson (encode)
>>> import Data.Aeson.Types (toJSONKeyText)
>>> import Data.OpenApi.Internal.Utils
>>> :set -XScopedTypeVariables
>>> :set -XDeriveAnyClass
>>> :set -XStandaloneDeriving
>>> :set -XTypeApplications
-}