{-# 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
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.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 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.Declare
import Data.OpenApi.Internal
import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
import Data.OpenApi.Lens hiding (name, schema)
import qualified Data.OpenApi.Lens as Swagger
import Data.OpenApi.SchemaOptions
import Data.OpenApi.Internal.TypeShape

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 Maybe Text
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 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) Schema
schema

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

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

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

-- | Convert a type into @'Schema'@.
--
-- An example type and instance:
--
-- @
-- {-\# LANGUAGE OverloadedStrings \#-}   -- allows to write 'T.Text' literals
-- {-\# LANGUAGE OverloadedLists \#-}     -- allows to write 'Map' and 'HashMap' as lists
--
-- import Control.Lens
-- import Data.Proxy
-- import Data.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 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 = SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep 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
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"TimeOfDay" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"hh:MM:ss"
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TimeOfDay -> Value
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 :: Proxy a -> Declare (Definitions Schema) Schema
declareSchema = (NamedSchema -> Schema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> Schema
_namedSchemaSchema (Declare (Definitions Schema) NamedSchema
 -> Declare (Definitions Schema) Schema)
-> (Proxy a -> Declare (Definitions Schema) NamedSchema)
-> Proxy a
-> Declare (Definitions Schema) Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Declare (Definitions Schema) NamedSchema
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 $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
-- {"type":"string"}
--
-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
-- Just "Day"
-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
-- {"example":"2016-07-22","format":"date","type":"string"}
toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
toNamedSchema :: Proxy a -> NamedSchema
toNamedSchema = Declare (Definitions Schema) NamedSchema -> NamedSchema
forall d a. Monoid d => Declare d a -> a
undeclare (Declare (Definitions Schema) NamedSchema -> NamedSchema)
-> (Proxy a -> Declare (Definitions Schema) NamedSchema)
-> Proxy a
-> NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Declare (Definitions Schema) NamedSchema
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 :: Proxy a -> Maybe Text
schemaName = NamedSchema -> Maybe Text
_namedSchemaName (NamedSchema -> Maybe Text)
-> (Proxy a -> NamedSchema) -> Proxy a -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> NamedSchema
forall a. ToSchema a => Proxy a -> NamedSchema
toNamedSchema

-- | Convert a type into a schema.
--
-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8)
-- {"maximum":127,"minimum":-128,"type":"integer"}
--
-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day])
-- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"}
toSchema :: ToSchema a => Proxy a -> Schema
toSchema :: Proxy a -> Schema
toSchema = NamedSchema -> Schema
_namedSchemaSchema (NamedSchema -> Schema)
-> (Proxy a -> NamedSchema) -> Proxy a -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> NamedSchema
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 $ encode $ toSchemaRef (Proxy :: Proxy Integer)
-- {"type":"integer"}
--
-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day)
-- {"$ref":"#/components/schemas/Day"}
toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
toSchemaRef :: Proxy a -> Referenced Schema
toSchemaRef = Declare (Definitions Schema) (Referenced Schema)
-> Referenced Schema
forall d a. Monoid d => Declare d a -> a
undeclare (Declare (Definitions Schema) (Referenced Schema)
 -> Referenced Schema)
-> (Proxy a -> Declare (Definitions Schema) (Referenced Schema))
-> Proxy a
-> Referenced Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Declare (Definitions Schema) (Referenced Schema)
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 :: Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef Proxy a
proxy = do
  case Proxy a -> NamedSchema
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 <- (Definitions Schema -> Bool)
-> DeclareT (Definitions Schema) Identity Bool
forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (Text -> Definitions Schema -> Bool
forall k a. (Eq k, Hashable k) => k -> InsOrdHashMap k a -> Bool
InsOrdHashMap.member Text
name)
      Bool
-> DeclareT (Definitions Schema) Identity ()
-> DeclareT (Definitions Schema) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
known) (DeclareT (Definitions Schema) Identity ()
 -> DeclareT (Definitions Schema) Identity ())
-> DeclareT (Definitions Schema) Identity ()
-> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [(Text
name, Schema
schema)]
        Declare (Definitions Schema) NamedSchema
-> DeclareT (Definitions Schema) Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Declare (Definitions Schema) NamedSchema
 -> DeclareT (Definitions Schema) Identity ())
-> Declare (Definitions Schema) NamedSchema
-> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy a
proxy
      Referenced Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall (m :: * -> *) a. Monad m => a -> m a
return (Referenced Schema
 -> Declare (Definitions Schema) (Referenced Schema))
-> Referenced Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Reference -> Referenced Schema
forall a. Reference -> Referenced a
Ref (Text -> Reference
Reference Text
name)
    NamedSchema
_ -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema)
-> Declare (Definitions Schema) Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) Schema
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 :: (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen Text -> Bool
p Definitions Schema
defs = (Referenced Schema -> Identity (Referenced Schema))
-> s -> Identity s
forall s a. (Data s, Typeable a) => Traversal' s a
template ((Referenced Schema -> Identity (Referenced Schema))
 -> s -> Identity s)
-> (Referenced Schema -> Referenced Schema) -> s -> s
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 Text -> Definitions Schema -> Maybe Schema
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
name Definitions Schema
defs of
            Just Schema
schema -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline ((Text -> Bool) -> Definitions Schema -> Schema -> Schema
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) = Schema -> Referenced Schema
forall a. a -> Referenced a
Inline ((Text -> Bool) -> Definitions Schema -> Schema -> Schema
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 :: [Text] -> Definitions Schema -> s -> s
inlineSchemas [Text]
names = (Text -> Bool) -> Definitions Schema -> s -> s
forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen (Text -> [Text] -> Bool
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 :: Definitions Schema -> s -> s
inlineAllSchemas = (Text -> Bool) -> Definitions Schema -> s -> s
forall s. Data s => (Text -> Bool) -> Definitions Schema -> s -> s
inlineSchemasWhen (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Convert a type into a schema without references.
--
-- >>> BSL.putStrLn $ encode $ toInlinedSchema (Proxy :: Proxy [Day])
-- {"items":{"example":"2016-07-22","format":"date","type":"string"},"type":"array"}
--
-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
-- when inlining recursive schemas.
toInlinedSchema :: ToSchema a => Proxy a -> Schema
toInlinedSchema :: Proxy a -> Schema
toInlinedSchema Proxy a
proxy = Definitions Schema -> Schema -> Schema
forall s. Data s => Definitions Schema -> s -> s
inlineAllSchemas Definitions Schema
defs Schema
schema
  where
    (Definitions Schema
defs, Schema
schema) = Declare (Definitions Schema) Schema
-> Definitions Schema -> (Definitions Schema, Schema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (Proxy a -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema Proxy a
proxy) Definitions Schema
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 :: Definitions Schema -> s -> s
inlineNonRecursiveSchemas Definitions Schema
defs = (Text -> Bool) -> Definitions Schema -> s -> s
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 Text -> Definitions Schema -> Maybe Schema
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 Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Declare [Text] () -> [Text] -> [Text]
forall d a. Declare d a -> d -> d
execDeclare (Schema -> Declare [Text] ()
usedNames Schema
schema) [Text]
forall a. Monoid a => a
mempty
        Maybe Schema
Nothing     -> Bool
False

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

    schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
    schemaRefNames :: Referenced Schema -> Declare [Text] ()
schemaRefNames Referenced Schema
ref = case Referenced Schema
ref of
      Ref (Reference Text
name) -> do
        Bool
seen <- ([Text] -> Bool) -> DeclareT [Text] Identity Bool
forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
        Bool -> Declare [Text] () -> Declare [Text] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
seen) (Declare [Text] () -> Declare [Text] ())
-> Declare [Text] () -> Declare [Text] ()
forall a b. (a -> b) -> a -> b
$ do
          [Text] -> Declare [Text] ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [Text
Item [Text]
name]
          (Schema -> Declare [Text] ()) -> Maybe Schema -> Declare [Text] ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Schema -> Declare [Text] ()
usedNames (Text -> Definitions Schema -> Maybe Schema
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
name Definitions Schema
defs)
      Inline Schema
subschema -> Schema -> Declare [Text] ()
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 $ encode $ sketchSchema "hello"
-- {"example":"hello","type":"string"}
--
-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3)
-- {"example":[1,2,3],"items":{"type":"number"},"type":"array"}
--
-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25)
-- {"example":["Jack",25],"items":[{"type":"string"},{"type":"number"}],"type":"array"}
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25)
-- {"example":{"age":25,"name":"Jack"},"required":["age","name"],"type":"object","properties":{"age":{"type":"number"},"name":{"type":"string"}}}
sketchSchema :: ToJSON a => a -> Schema
sketchSchema :: a -> Schema
sketchSchema = Value -> Schema
sketch (Value -> Schema) -> (a -> Value) -> a -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
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 Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
js

    go :: Value -> Schema
go Value
Null       = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiNull
    go (Bool Bool
_)   = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiBoolean
    go (String Text
_) = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
    go (Number Scientific
_) = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiNumber
    go (Array Array
xs) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_   ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
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 (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
s)
          Maybe Schema
_      -> [Referenced Schema] -> OpenApiItems
OpenApiItemsArray ((Schema -> Referenced Schema) -> [Schema] -> [Referenced Schema]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Referenced Schema
forall a. a -> Referenced a
Inline [Schema]
ys)
      where
        ys :: [Schema]
ys = (Value -> Schema) -> [Value] -> [Schema]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Schema
go (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs)
        allSame :: Bool
allSame = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((Schema -> Schema -> Bool) -> [Schema] -> [Schema] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Schema -> Schema -> Bool
forall a. Eq a => a -> a -> Bool
(==)) [Schema]
ys ([Schema] -> [Schema]
forall a. [a] -> [a]
tail [Schema]
ys))

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

-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema uses as much constraints as possible.
--
-- >>> BSL.putStrLn $ encode $ sketchStrictSchema "hello"
-- {"maxLength":5,"pattern":"hello","minLength":5,"type":"string","enum":["hello"]}
--
-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (1, 2, 3)
-- {"minItems":3,"uniqueItems":true,"items":[{"maximum":1,"minimum":1,"multipleOf":1,"type":"number","enum":[1]},{"maximum":2,"minimum":2,"multipleOf":2,"type":"number","enum":[2]},{"maximum":3,"minimum":3,"multipleOf":3,"type":"number","enum":[3]}],"maxItems":3,"type":"array","enum":[[1,2,3]]}
--
-- >>> BSL.putStrLn $ encode $ sketchStrictSchema ("Jack", 25)
-- {"minItems":2,"uniqueItems":true,"items":[{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]},{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]}],"maxItems":2,"type":"array","enum":[["Jack",25]]}
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25)
-- {"minProperties":2,"required":["age","name"],"maxProperties":2,"type":"object","enum":[{"age":25,"name":"Jack"}],"properties":{"age":{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]},"name":{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]}}}
sketchStrictSchema :: ToJSON a => a -> Schema
sketchStrictSchema :: a -> Schema
sketchStrictSchema = Value -> Schema
go (Value -> Schema) -> (a -> Value) -> a -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
  where
    go :: Value -> Schema
go Value
Null       = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiNull
    go js :: Value
js@(Bool Bool
_) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiBoolean
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
Item [Value]
js]
    go js :: Value
js@(String Text
s) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMaxLength s a => Lens' s a
maxLength ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
s)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinLength s a => Lens' s a
minLength ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
s)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasPattern s a => Lens' s a
pattern   ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
s
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_     ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
Item [Value]
js]
    go js :: Value
js@(Number Scientific
n) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_       ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiNumber
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMaximum s a => Lens' s a
maximum_    ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMinimum s a => Lens' s a
minimum_    ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMultipleOf s a => Lens' s a
multipleOf  ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Scientific
n
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_       ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
Item [Value]
js]
    go js :: Value
js@(Array Array
xs) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_       ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMaxItems s a => Lens' s a
maxItems    ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinItems s a => Lens' s a
minItems    ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items       ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Referenced Schema] -> OpenApiItems
OpenApiItemsArray ((Value -> Referenced Schema) -> [Value] -> [Referenced Schema]
forall a b. (a -> b) -> [a] -> [b]
map (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema)
-> (Value -> Schema) -> Value -> Referenced Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Schema
go) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs))
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasUniqueItems s a => Lens' s a
uniqueItems ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
allUnique
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_       ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
Item [Value]
js]
      where
        sz :: Int
sz = Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Array
xs
        allUnique :: Bool
allUnique = Int
sz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== HashSet Value -> Int
forall a. HashSet a -> Int
HashSet.size ([Value] -> HashSet Value
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs))
    go js :: Value
js@(Object Object
o) = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_         ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required      (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text]
names
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties    ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Value -> Referenced Schema)
-> InsOrdHashMap Text Value
-> InsOrdHashMap Text (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema)
-> (Value -> Schema) -> Value -> Referenced Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Schema
go) (Object -> InsOrdHashMap Text Value
forall k v. HashMap k v -> InsOrdHashMap k v
InsOrdHashMap.fromHashMap Object
o)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMaxProperties s a => Lens' s a
maxProperties ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
names)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinProperties s a => Lens' s a
minProperties ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
names)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_         ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
Item [Value]
js]
      where
        names :: [Text]
names = Object -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys 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 <- Proxy a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy String -> Schema)
-> Proxy String
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy String -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Bool -> Schema)
-> Proxy Bool
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Bool -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Integer -> Schema)
-> Proxy Integer
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Integer -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Natural -> Schema)
-> Proxy Natural
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Natural -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Int -> Schema)
-> Proxy Int
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Int -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Int8 -> Schema)
-> Proxy Int8
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Int8 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Int16 -> Schema)
-> Proxy Int16
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Int16 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Int32 -> Schema)
-> Proxy Int32
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Int32 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Int64 -> Schema)
-> Proxy Int64
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Int64 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Word -> Schema)
-> Proxy Word
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Word -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Word8 -> Schema)
-> Proxy Word8
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Word8 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Word16 -> Schema)
-> Proxy Word16
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Word16 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Word32 -> Schema)
-> Proxy Word32
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Word32 -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Word64 -> Schema)
-> Proxy Word64
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Word64 -> Schema
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 (Proxy Char -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy Char
proxy)
    Declare (Definitions Schema) NamedSchema
-> (Declare (Definitions Schema) NamedSchema
    -> Declare (Definitions Schema) NamedSchema)
-> Declare (Definitions Schema) NamedSchema
forall a b. a -> (a -> b) -> b
& (NamedSchema -> Identity NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Identity (Declare (Definitions Schema) NamedSchema)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped((NamedSchema -> Identity NamedSchema)
 -> Declare (Definitions Schema) NamedSchema
 -> Identity (Declare (Definitions Schema) NamedSchema))
-> ((Maybe Value -> Identity (Maybe Value))
    -> NamedSchema -> Identity NamedSchema)
-> (Maybe Value -> Identity (Maybe Value))
-> Declare (Definitions Schema) NamedSchema
-> Identity (Declare (Definitions Schema) NamedSchema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Schema -> Identity Schema) -> NamedSchema -> Identity NamedSchema
forall s a. HasSchema s a => Lens' s a
Swagger.schema((Schema -> Identity Schema)
 -> NamedSchema -> Identity NamedSchema)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Schema -> Identity Schema)
-> (Maybe Value -> Identity (Maybe Value))
-> NamedSchema
-> Identity NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Declare (Definitions Schema) NamedSchema
 -> Identity (Declare (Definitions Schema) NamedSchema))
-> Value
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Char -> Value
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Scientific -> Schema)
-> Proxy Scientific
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Scientific -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Double -> Schema)
-> Proxy Double
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Double -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Float -> Schema)
-> Proxy Float
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Float -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema :: Proxy (Fixed a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Schema -> Declare (Definitions Schema) NamedSchema
plain (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy (Fixed a) -> Schema)
-> Proxy (Fixed a)
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Fixed a) -> Schema
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)
_ = Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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 = SchemaOptions
-> Proxy (Either a b) -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep 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 ()
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
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 = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"UUID" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Proxy UUID -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy UUID
p
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> Value
forall a. ToJSON a => a -> Value
toJSON (UUID -> Text
UUID.toText UUID
UUID.nil)

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

timeSchema :: T.Text -> Schema
timeSchema :: Text -> Schema
timeSchema Text
fmt = Schema
forall a. Monoid a => a
mempty
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasFormat s a => Lens' s a
format ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
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
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"Day" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"date"
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Day -> Value
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
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"LocalTime" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"yyyy-mm-ddThh:MM:ss"
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ LocalTime -> Value
forall a. ToJSON a => a -> Value
toJSON (Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2016 Int
7 Int
22) (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
7 Int
40 Pico
0))

-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
instance ToSchema ZonedTime where
  declareNamedSchema :: Proxy ZonedTime -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ZonedTime
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"ZonedTime" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"date-time"
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ZonedTime -> Value
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
_ = Proxy Pico -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy Pico
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
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> NamedSchema
named Text
"UTCTime" (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
timeSchema Text
"yyyy-mm-ddThh:MM:ssZ"
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ UTCTime -> Value
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Text -> Schema)
-> Proxy Text
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Text -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Text -> Schema)
-> Proxy Text
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Text -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Version -> Schema)
-> Proxy Version
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Version -> Schema
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 = String
-> Proxy ByteString -> Declare (Definitions Schema) NamedSchema
forall a. HasCallStack => String -> a
error String
"impossible"
instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema :: Proxy ByteString -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = String
-> Proxy ByteString -> Declare (Definitions Schema) NamedSchema
forall a. HasCallStack => String -> a
error String
"impossible"

instance ToSchema IntSet where declareNamedSchema :: Proxy IntSet -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy IntSet
_ = Proxy (Set Int) -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy (Set Int)
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)
_ = Proxy [(Int, a)] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [(Int, a)]
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 ToJSONKeyFunction k
forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey :: ToJSONKeyFunction k of
      ToJSONKeyText  k -> Text
_ k -> Encoding' Text
_ -> Declare (Definitions Schema) NamedSchema
declareObjectMapSchema
      ToJSONKeyValue k -> Value
_ k -> Encoding
_ -> Proxy [(k, v)] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [(k, v)]
forall k (t :: k). Proxy t
Proxy :: Proxy [(k, v)])
    where
      declareObjectMapSchema :: Declare (Definitions Schema) NamedSchema
declareObjectMapSchema = do
        Referenced Schema
schema <- Proxy v -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy v
forall k (t :: k). Proxy t
Proxy :: Proxy v)
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe AdditionalProperties
 -> Identity (Maybe AdditionalProperties))
-> Schema -> Identity Schema
forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties ((Maybe AdditionalProperties
  -> Identity (Maybe AdditionalProperties))
 -> Schema -> Identity Schema)
-> AdditionalProperties -> Schema -> Schema
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)
_ = Proxy (Map k v) -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy (Map k v)
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
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Object") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"Arbitrary JSON object."
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe AdditionalProperties
 -> Identity (Maybe AdditionalProperties))
-> Schema -> Identity Schema
forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties ((Maybe AdditionalProperties
  -> Identity (Maybe AdditionalProperties))
 -> Schema -> Identity Schema)
-> AdditionalProperties -> Schema -> Schema
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)
_ = Proxy [a] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [a]
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)
_ = Proxy [a] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [a]
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)
_ = Proxy [a] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [a]
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)
_ = Proxy [a] -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy [a]
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 <- Proxy [a] -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (Proxy [a]
forall k (t :: k). Proxy t
Proxy :: Proxy [a])
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
schema
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasUniqueItems s a => Lens' s a
uniqueItems ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
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)
_ = Proxy (Set a) -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy (Set a)
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 <- Proxy [a] -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (Proxy [a]
forall k (t :: k). Proxy t
Proxy :: Proxy [a])
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
schema
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinItems s a => Lens' s a
minItems ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Maybe Integer -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Maybe Integer
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy All -> Schema)
-> Proxy All
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy All -> Schema
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 (Schema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy Any -> Schema)
-> Proxy Any
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Any -> Schema
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
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)
_ = Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

-- | Default schema for @'Bounded'@, @'Integral'@ types.
--
-- >>> BSL.putStrLn $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
-- {"maximum":32767,"minimum":-32768,"type":"integer"}
toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral :: Proxy a -> Schema
toSchemaBoundedIntegral Proxy a
_ = Schema
forall a. Monoid a => a
mempty
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiInteger
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMinimum s a => Lens' s a
minimum_ ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
minBound :: a))
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Scientific -> Identity (Maybe Scientific))
-> Schema -> Identity Schema
forall s a. HasMaximum s a => Lens' s a
maximum_ ((Maybe Scientific -> Identity (Maybe Scientific))
 -> Schema -> Identity Schema)
-> Scientific -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
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 :: SchemaOptions -> Proxy a -> NamedSchema
genericToNamedSchemaBoundedIntegral SchemaOptions
opts Proxy a
proxy
  = SchemaOptions -> Proxy a -> Schema -> NamedSchema
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 (Proxy a -> Schema
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 :: 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 = SchemaOptions -> Proxy a -> Schema -> NamedSchema
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 (Schema -> NamedSchema)
-> Declare (Definitions Schema) Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy inner -> Declare (Definitions Schema) Schema
f (Proxy inner
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 $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
--
-- 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 :: Proxy (map key value) -> Declare (Definitions Schema) Schema
declareSchemaBoundedEnumKeyMapping Proxy (map key value)
_ = case ToJSONKeyFunction key
forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey :: ToJSONKeyFunction key of
  ToJSONKeyText key -> Text
keyToText key -> Encoding' Text
_ -> (key -> Text) -> Declare (Definitions Schema) Schema
objectSchema key -> Text
keyToText
  ToJSONKeyValue key -> Value
_ key -> Encoding
_ -> Proxy [(key, value)] -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (Proxy [(key, value)]
forall k (t :: k). Proxy t
Proxy :: Proxy [(key, value)])
  where
    objectSchema :: (key -> Text) -> Declare (Definitions Schema) Schema
objectSchema key -> Text
keyToText = do
      Referenced Schema
valueRef <- Proxy value -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy value
forall k (t :: k). Proxy t
Proxy :: Proxy value)
      let allKeys :: [key]
allKeys   = [Item [key]
forall a. Bounded a => a
minBound..key
forall a. Bounded a => a
maxBound :: key]
          mkPair :: key -> (Text, Referenced Schema)
mkPair key
k  =  (key -> Text
keyToText key
k, Referenced Schema
valueRef)
      Schema -> Declare (Definitions Schema) Schema
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> Declare (Definitions Schema) Schema)
-> Schema -> Declare (Definitions Schema) Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList ((key -> (Text, Referenced Schema))
-> [key] -> [(Text, Referenced Schema)]
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 $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
--
-- 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 :: Proxy (map key value) -> Schema
toSchemaBoundedEnumKeyMapping = (Declare (Definitions Schema) Schema
 -> Definitions Schema -> Schema)
-> Definitions Schema
-> Declare (Definitions Schema) Schema
-> Schema
forall a b c. (a -> b -> c) -> b -> a -> c
flip Declare (Definitions Schema) Schema -> Definitions Schema -> Schema
forall d a. Declare d a -> d -> a
evalDeclare Definitions Schema
forall a. Monoid a => a
mempty (Declare (Definitions Schema) Schema -> Schema)
-> (Proxy (map key value) -> Declare (Definitions Schema) Schema)
-> Proxy (map key value)
-> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (map key value) -> Declare (Definitions Schema) Schema
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)) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema :: SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema SchemaOptions
opts Proxy a
proxy = NamedSchema -> Schema
_namedSchemaSchema (NamedSchema -> Schema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep 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'@.
genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema :: SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
opts Proxy a
_ = SchemaOptions
-> Proxy (Rep a)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy (Rep a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Rep a)) Schema
forall a. Monoid a => a
mempty

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

gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
gdatatypeSchemaName :: 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 -> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack String
name)
  String
_ -> Maybe Text
forall a. Maybe a
Nothing
  where
    orig :: String
orig = Proxy3 d Any Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall k k (f :: k) (a :: k). Proxy3 d f a
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 :: SchemaOptions -> Proxy a -> NamedSchema
paramSchemaToNamedSchema SchemaOptions
opts Proxy a
proxy = SchemaOptions -> Proxy a -> Schema -> NamedSchema
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 (Proxy a -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema Proxy a
proxy)

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

nullarySchema :: Schema
nullarySchema :: Schema
nullarySchema = Schema
forall a. Monoid a => a
mempty
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
  Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
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 :: SchemaOptions -> Proxy f -> NamedSchema
gtoNamedSchema SchemaOptions
opts Proxy f
proxy = Declare (Definitions Schema) NamedSchema -> NamedSchema
forall d a. Monoid d => Declare d a -> a
undeclare (Declare (Definitions Schema) NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy f
proxy Schema
forall a. Monoid a => a
mempty

gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema :: SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema SchemaOptions
opts Proxy f
proxy = NamedSchema -> Schema
_namedSchemaSchema (NamedSchema -> Schema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy f
proxy Schema
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 <- SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f) Schema
schema
    SchemaOptions
-> Proxy g -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy g
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 (NamedSchema -> NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f) Schema
s
    where
      name :: Maybe Text
name = SchemaOptions -> Proxy d -> Maybe Text
forall k (d :: k).
Datatype d =>
SchemaOptions -> Proxy d -> Maybe Text
gdatatypeSchemaName SchemaOptions
opts (Proxy d
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)
_ = SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy f
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 = SchemaOptions
-> Proxy (C1 c U1)
-> Schema
-> Declare (Definitions Schema) NamedSchema
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 Schema
-> Getting (Maybe OpenApiItems) Schema (Maybe OpenApiItems)
-> Maybe OpenApiItems
forall s a. s -> Getting a s a -> a
^. Getting (Maybe OpenApiItems) Schema (Maybe OpenApiItems)
forall s a. HasItems s a => Lens' s a
items of
          Just (OpenApiItemsArray [Item [Referenced Schema]
_]) -> Declare (Definitions Schema) NamedSchema
fieldSchema
          Maybe OpenApiItems
_ -> do
            Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare Definitions Schema
defs
            NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> NamedSchema
unnamed Schema
schema)
    where
      (Definitions Schema
defs, NamedSchema Maybe Text
_ Schema
schema) = Declare (Definitions Schema) NamedSchema
-> Definitions Schema -> (Definitions Schema, NamedSchema)
forall d a. Declare d a -> d -> (d, a)
runDeclare Declare (Definitions Schema) NamedSchema
recordSchema Definitions Schema
forall a. Monoid a => a
mempty
      recordSchema :: Declare (Definitions Schema) NamedSchema
recordSchema = SchemaOptions
-> Proxy (S1 s f)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy (S1 s f)
forall k (t :: k). Proxy t
Proxy :: Proxy (S1 s f)) Schema
s
      fieldSchema :: Declare (Definitions Schema) NamedSchema
fieldSchema  = SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f) Schema
s

gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef :: SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts Proxy a
proxy = do
  case SchemaOptions -> Proxy a -> NamedSchema
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 <- (Definitions Schema -> Bool)
-> DeclareT (Definitions Schema) Identity Bool
forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (Text -> Definitions Schema -> Bool
forall k a. (Eq k, Hashable k) => k -> InsOrdHashMap k a -> Bool
InsOrdHashMap.member Text
name)
      Bool
-> DeclareT (Definitions Schema) Identity ()
-> DeclareT (Definitions Schema) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
known) (DeclareT (Definitions Schema) Identity ()
 -> DeclareT (Definitions Schema) Identity ())
-> DeclareT (Definitions Schema) Identity ()
-> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare [(Text
name, Schema
schema)]
        Declare (Definitions Schema) NamedSchema
-> DeclareT (Definitions Schema) Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Declare (Definitions Schema) NamedSchema
 -> DeclareT (Definitions Schema) Identity ())
-> Declare (Definitions Schema) NamedSchema
-> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ SchemaOptions
-> Proxy a -> Schema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *).
GToSchema f =>
SchemaOptions
-> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSchema SchemaOptions
opts Proxy a
proxy Schema
forall a. Monoid a => a
mempty
      Referenced Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall (m :: * -> *) a. Monad m => a -> m a
return (Referenced Schema
 -> Declare (Definitions Schema) (Referenced Schema))
-> Referenced Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Reference -> Referenced Schema
forall a. Reference -> Referenced a
Ref (Text -> Reference
Reference Text
name)
    NamedSchema
_ -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema)
-> Declare (Definitions Schema) Schema
-> Declare (Definitions Schema) (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
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 = OpenApiItems -> Maybe OpenApiItems
forall a. a -> Maybe a
Just ([Referenced Schema] -> OpenApiItems
OpenApiItemsArray [Item [Referenced Schema]
Referenced Schema
x])
appendItem Referenced Schema
x (Just (OpenApiItemsArray [Referenced Schema]
xs)) = OpenApiItems -> Maybe OpenApiItems
forall a. a -> Maybe a
Just ([Referenced Schema] -> OpenApiItems
OpenApiItemsArray ([Referenced Schema]
xs [Referenced Schema] -> [Referenced Schema] -> [Referenced Schema]
forall a. [a] -> [a] -> [a]
++ [Item [Referenced Schema]
Referenced Schema
x]))
appendItem Referenced Schema
_ Maybe OpenApiItems
_ = String -> 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 :: SchemaOptions
-> proxy s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
withFieldSchema SchemaOptions
opts proxy s f
_ Bool
isRequiredField Schema
schema = do
  Referenced Schema
ref <- SchemaOptions
-> Proxy f -> Declare (Definitions Schema) (Referenced Schema)
forall (a :: * -> *).
GToSchema a =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f)
  Schema -> Declare (Definitions Schema) Schema
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> Declare (Definitions Schema) Schema)
-> Schema -> Declare (Definitions Schema) Schema
forall a b. (a -> b) -> a -> b
$
    if Text -> Bool
T.null Text
fname
      then Schema
schema
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> (Maybe OpenApiItems -> Maybe OpenApiItems) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
appendItem Referenced Schema
ref
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMaxItems s a => Lens' s a
maxItems ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> (Maybe Integer -> Maybe Integer) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Maybe Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)   -- increment maxItems
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinItems s a => Lens' s a
minItems ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> (Maybe Integer -> Maybe Integer) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Maybe Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)   -- increment minItems
      else Schema
schema
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (InsOrdHashMap Text (Referenced Schema))
fname ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& if Bool
isRequiredField
            then ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> ([Text] -> [Text]) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
Item [Text]
fname])
            else Schema -> Schema
forall a. a -> a
id
  where
    fname :: Text
fname = String -> Text
T.pack (SchemaOptions -> String -> String
fieldLabelModifier SchemaOptions
opts (Proxy3 s f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall k (p :: k). Proxy3 s f p
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)))
_ = (Schema -> NamedSchema)
-> Declare (Definitions Schema) Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> NamedSchema
unnamed (Declare (Definitions Schema) Schema
 -> Declare (Definitions Schema) NamedSchema)
-> (Schema -> Declare (Definitions Schema) Schema)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaOptions
-> Proxy2 s (K1 i (Maybe c))
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
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. Proxy2 s (K1 i (Maybe c))
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)
_ = (Schema -> NamedSchema)
-> Declare (Definitions Schema) Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> NamedSchema
unnamed (Declare (Definitions Schema) Schema
 -> Declare (Definitions Schema) NamedSchema)
-> (Schema -> Declare (Definitions Schema) Schema)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaOptions
-> Proxy2 s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
forall k (proxy :: k -> (* -> *) -> *) (s :: k) (f :: * -> *).
(Selector s, GToSchema f) =>
SchemaOptions
-> proxy s f
-> Bool
-> Schema
-> Declare (Definitions Schema) Schema
withFieldSchema SchemaOptions
opts (Proxy2 s f
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
_ = Proxy c -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy c
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
_ = Proxy c -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy c
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 = SchemaOptions
-> Proxy (f :+: g)
-> Schema
-> Declare (Definitions Schema) NamedSchema
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 :: 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 = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
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
_) <- WriterT
  All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
-> Declare (Definitions Schema) ([(Text, Referenced Schema)], All)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
declareSumSchema
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema -> NamedSchema
unnamed (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasOneOf s a => Lens' s a
oneOf ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ((Text, Referenced Schema) -> Referenced Schema
forall a b. (a, b) -> b
snd ((Text, Referenced Schema) -> Referenced Schema)
-> [(Text, Referenced Schema)] -> [Referenced Schema]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Referenced Schema)]
schemas)
  where
    declareSumSchema :: WriterT
  All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
declareSumSchema = SchemaOptions
-> Proxy f
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy f
proxy
    ([(Text, Referenced Schema)]
sumSchemas, All Bool
allNullary) = Declare (Definitions Schema) ([(Text, Referenced Schema)], All)
-> ([(Text, Referenced Schema)], All)
forall d a. Monoid d => Declare d a -> a
undeclare (WriterT
  All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
-> Declare (Definitions Schema) ([(Text, Referenced Schema)], All)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
declareSumSchema)

    toStringTag :: [(Text, Referenced Schema)] -> Schema
toStringTag [(Text, Referenced Schema)]
schemas = Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ((Text, Referenced Schema) -> Value)
-> [(Text, Referenced Schema)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value
String (Text -> Value)
-> ((Text, Referenced Schema) -> Text)
-> (Text, Referenced Schema)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Referenced Schema) -> Text
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 (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (f :+: g)
_ =
    [(Text, Referenced Schema)]
-> [(Text, Referenced Schema)] -> [(Text, Referenced Schema)]
forall a. Semigroup a => a -> a -> a
(<>) ([(Text, Referenced Schema)]
 -> [(Text, Referenced Schema)] -> [(Text, Referenced Schema)])
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
-> WriterT
     All
     (Declare (Definitions Schema))
     ([(Text, Referenced Schema)] -> [(Text, Referenced Schema)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaOptions
-> Proxy f
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f) WriterT
  All
  (Declare (Definitions Schema))
  ([(Text, Referenced Schema)] -> [(Text, Referenced Schema)])
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SchemaOptions
-> Proxy g
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (f :: * -> *).
GSumToSchema f =>
SchemaOptions
-> Proxy f
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts (Proxy g
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 :: 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 Schema
-> Getting (Maybe OpenApiType) Schema (Maybe OpenApiType)
-> Maybe OpenApiType
forall s a. s -> Getting a s a -> a
^. Getting (Maybe OpenApiType) Schema (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
type_ Maybe OpenApiType -> Maybe OpenApiType -> Bool
forall a. Eq a => a -> a -> Bool
== OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiObject Bool -> Bool -> Bool
&& Bool
isRecord -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
sub
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [String -> Text
T.pack String
tagField]
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Text
T.pack String
tagField) ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
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 -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [String -> Text
T.pack String
tagField]
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Text
T.pack String
tagField) ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
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.
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& case Maybe (Referenced Schema)
ref of
                Just Referenced Schema
r -> ((InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Text
T.pack String
contentsField) ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
r) (Schema -> Schema) -> (Schema -> Schema) -> Schema -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [String -> Text
T.pack String
contentsField])
                Maybe (Referenced Schema)
Nothing -> Schema -> Schema
forall a. a -> a
id

          -- In the remaining cases we combine "tag" object and "contents" object using allOf.
          Maybe (Referenced Schema)
_ -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasAllOf s a => Lens' s a
allOf ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (String -> Text
T.pack String
tagField Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: if Bool
isRecord then [] else [String -> Text
T.pack String
contentsField])
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Text
T.pack String
tagField) ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Text -> Value
String Text
tag])]
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& if Bool
isRecord
                 then (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasAllOf s a => Lens' s a
allOf ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> (([Referenced Schema] -> Identity [Referenced Schema])
    -> Maybe [Referenced Schema]
    -> Identity (Maybe [Referenced Schema]))
-> ([Referenced Schema] -> Identity [Referenced Schema])
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Referenced Schema] -> Identity [Referenced Schema])
-> Maybe [Referenced Schema]
-> Identity (Maybe [Referenced Schema])
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (([Referenced Schema] -> Identity [Referenced Schema])
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Item [Referenced Schema]
Referenced Schema
refOrNullary]
                 else (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasAllOf s a => Lens' s a
allOf ((Maybe [Referenced Schema]
  -> Identity (Maybe [Referenced Schema]))
 -> Schema -> Identity Schema)
-> (([Referenced Schema] -> Identity [Referenced Schema])
    -> Maybe [Referenced Schema]
    -> Identity (Maybe [Referenced Schema]))
-> ([Referenced Schema] -> Identity [Referenced Schema])
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Referenced Schema] -> Identity [Referenced Schema])
-> Maybe [Referenced Schema]
-> Identity (Maybe [Referenced Schema])
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (([Referenced Schema] -> Identity [Referenced Schema])
 -> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Text
T.pack String
contentsField) ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
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 -> Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
Item [Text]
tag]
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (InsOrdHashMap Text (Referenced Schema))
tag ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
refOrNullary
      SumEncoding
TwoElemArray -> String -> Referenced Schema
forall a. HasCallStack => String -> a
error String
"unrepresentable in OpenAPI 3"

    tag :: Text
tag = String -> Text
T.pack (SchemaOptions -> String -> String
constructorTagModifier SchemaOptions
opts (Proxy3 c f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall k (p :: k). Proxy3 c f p
forall k k k (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 c f p)))
    isRecord :: Bool
isRecord = Proxy3 c f Any -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord (forall k (p :: k). Proxy3 c f p
forall k k k (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 :: Proxy3 c f p)
    refOrNullary :: Referenced Schema
refOrNullary = Referenced Schema -> Maybe (Referenced Schema) -> Referenced Schema
forall a. a -> Maybe a -> a
fromMaybe (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
nullarySchema) Maybe (Referenced Schema)
ref
    refOrEnum :: Referenced Schema
refOrEnum = Referenced Schema -> Maybe (Referenced Schema) -> Referenced Schema
forall a. a -> Maybe a -> a
fromMaybe (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
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 :: SchemaOptions
-> Proxy (C1 c f)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
gsumConToSchema SchemaOptions
opts Proxy (C1 c f)
proxy = do
  Referenced Schema
ref <- SchemaOptions
-> Proxy (C1 c f)
-> Declare (Definitions Schema) (Referenced Schema)
forall (a :: * -> *).
GToSchema a =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef SchemaOptions
opts Proxy (C1 c f)
proxy
  [(Text, Referenced Schema)]
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe (Referenced Schema)
-> SchemaOptions -> Proxy (C1 c f) -> (Text, Referenced Schema)
forall (c :: Meta) (f :: * -> *).
(GToSchema (C1 c f), Constructor c) =>
Maybe (Referenced Schema)
-> SchemaOptions -> Proxy (C1 c f) -> (Text, Referenced Schema)
gsumConToSchemaWith (Referenced Schema -> Maybe (Referenced Schema)
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 (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (C1 c f)
proxy = do
    All -> WriterT All (Declare (Definitions Schema)) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False)
    Declare (Definitions Schema) [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Declare (Definitions Schema) [(Text, Referenced Schema)]
 -> WriterT
      All (Declare (Definitions Schema)) [(Text, Referenced Schema)])
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ SchemaOptions
-> Proxy (C1 c f)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
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 (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (C1 c (S1 s f))
proxy = do
    All -> WriterT All (Declare (Definitions Schema)) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False)
    Declare (Definitions Schema) [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Declare (Definitions Schema) [(Text, Referenced Schema)]
 -> WriterT
      All (Declare (Definitions Schema)) [(Text, Referenced Schema)])
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ SchemaOptions
-> Proxy (C1 c (S1 s f))
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
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 (Declare (Definitions Schema)) [(Text, Referenced Schema)]
gsumToSchema SchemaOptions
opts Proxy (C1 c U1)
proxy = [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Referenced Schema)]
 -> WriterT
      All (Declare (Definitions Schema)) [(Text, Referenced Schema)])
-> [(Text, Referenced Schema)]
-> WriterT
     All (Declare (Definitions Schema)) [(Text, Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ ((Text, Referenced Schema)
-> [(Text, Referenced Schema)] -> [(Text, Referenced Schema)]
forall a. a -> [a] -> [a]
:[]) ((Text, Referenced Schema) -> [(Text, Referenced Schema)])
-> (Text, Referenced Schema) -> [(Text, Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ Maybe (Referenced Schema)
-> SchemaOptions -> Proxy (C1 c U1) -> (Text, Referenced Schema)
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)
forall a. Maybe a
Nothing SchemaOptions
opts Proxy (C1 c U1)
proxy

data Proxy2 a b = Proxy2

data Proxy3 a b c = Proxy3

-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
--
-- Intended usage:
--
-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
-- >>> :{
-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
--   declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
-- :}
--
-- >>> toNamedSchema @(Foo Int) Proxy ^. name
-- Just "Foo_Int"
-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
-- Just "Foo_Bool"
-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
-- Just "Foo_(Foo_Text)"
class ToSchema1 (f :: * -> *) where
  declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema

  -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
  -- above, however sadly GHC does not like it.
  default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
  declareNamedSchema1 Proxy f
_ Proxy a
_ = SchemaOptions
-> Proxy (f a) -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a)) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema @(f a) SchemaOptions
defaultSchemaOptions Proxy (f a)
forall k (t :: k). Proxy t
Proxy

{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
using 'ToSchema1' instance, like this:

#if __GLASGOW_HASKELL__ >= 806
>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
#else
> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
#endif
-}
newtype BySchema1 f a = BySchema1 (f a)

instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
  declareNamedSchema :: Proxy (BySchema1 f a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (BySchema1 f a)
_ = do
    NamedSchema
sch <- Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a.
(ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), ToSchema a) =>
Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema1 @f @a Proxy f
forall k (t :: k). Proxy t
Proxy Proxy a
forall k (t :: k). Proxy t
Proxy
    let tName :: Text
tName = Text -> Text -> Text -> Text
T.replace Text
" " Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep (f a) -> String
forall a. Show a => a -> String
show (TypeRep (f a) -> String) -> TypeRep (f a) -> String
forall a b. (a -> b) -> a -> b
$ Typeable (f a) => TypeRep (f a)
forall k (a :: k). Typeable a => TypeRep a
typeRep @(f a)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> NamedSchema -> NamedSchema
rename (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tName) NamedSchema
sch

{- $setup
>>> import Data.OpenApi
>>> import Data.Aeson (encode)
>>> import Data.Aeson.Types (toJSONKeyText)
>>> :set -XScopedTypeVariables
>>> :set -XDeriveAnyClass
>>> :set -XStandaloneDeriving
>>> :set -XTypeApplications
#if __GLASGOW_HASKELL__ >= 806
>>> :set -XDerivingVia
#endif
-}