{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Autodocodec.OpenAPI.Schema where

import Autodocodec
import Control.Lens (Lens', (&), (.~), (?~), (^.))
import Control.Monad
import Control.Monad.State.Lazy (StateT, evalStateT, runStateT)
import qualified Control.Monad.State.Lazy as State
import Control.Monad.Trans (lift)
import qualified Data.Aeson as Aeson
import qualified Data.Foldable as Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.OpenApi as OpenAPI
import Data.OpenApi.Declare as OpenAPI
import Data.Proxy
import Data.Scientific
import Data.Text (Text)

-- | Use a type's 'codec' to implement 'declareNamedSchema'.
declareNamedSchemaViaCodec :: (HasCodec value) => Proxy value -> Declare (Definitions Schema) NamedSchema
declareNamedSchemaViaCodec :: forall value.
HasCodec value =>
Proxy value -> Declare (Definitions Schema) NamedSchema
declareNamedSchemaViaCodec Proxy value
proxy = JSONCodec value
-> Proxy value -> Declare (Definitions Schema) NamedSchema
forall value.
JSONCodec value
-> Proxy value -> Declare (Definitions Schema) NamedSchema
declareNamedSchemaVia JSONCodec value
forall value. HasCodec value => JSONCodec value
codec Proxy value
proxy

-- | Use a given 'codec' to implement 'declareNamedSchema'.
declareNamedSchemaVia :: JSONCodec value -> Proxy value -> Declare (Definitions Schema) NamedSchema
declareNamedSchemaVia :: forall value.
JSONCodec value
-> Proxy value -> Declare (Definitions Schema) NamedSchema
declareNamedSchemaVia JSONCodec value
c' Proxy value
Proxy = StateT
  (HashMap Text Schema)
  (DeclareT (Definitions Schema) Identity)
  NamedSchema
-> HashMap Text Schema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (JSONCodec value
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go JSONCodec value
c') HashMap Text Schema
forall a. Monoid a => a
mempty
  where
    go :: ValueCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) NamedSchema
    go :: forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go = \case
      ValueCodec input output
NullCodec ->
        NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a.
a
-> StateT
     (HashMap Text Schema) (DeclareT (Definitions Schema) Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
            Schema
forall a. Monoid a => a
mempty
              { _schemaType = Just OpenApiNull
              }
      BoolCodec Maybe Text
mname -> Declare (Definitions Schema) NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (HashMap Text Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Declare (Definitions Schema) NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
mname (Schema -> NamedSchema)
-> DeclareT (Definitions Schema) Identity Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Bool -> DeclareT (Definitions Schema) Identity Schema
forall a.
ToSchema a =>
Proxy a -> DeclareT (Definitions Schema) Identity Schema
declareSchema (Proxy Bool
forall {k} (t :: k). Proxy t
Proxy :: Proxy Bool)
      StringCodec Maybe Text
mname -> Declare (Definitions Schema) NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (HashMap Text Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Declare (Definitions Schema) NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> Declare (Definitions Schema) NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
mname (Schema -> NamedSchema)
-> DeclareT (Definitions Schema) Identity Schema
-> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Text -> DeclareT (Definitions Schema) Identity Schema
forall a.
ToSchema a =>
Proxy a -> DeclareT (Definitions Schema) Identity Schema
declareSchema (Proxy Text
forall {k} (t :: k). Proxy t
Proxy :: Proxy Text)
      IntegerCodec Maybe Text
mname Bounds Integer
mBounds -> do
        s <- DeclareT (Definitions Schema) Identity Schema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     Schema
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (HashMap Text Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DeclareT (Definitions Schema) Identity Schema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      Schema)
-> DeclareT (Definitions Schema) Identity Schema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     Schema
forall a b. (a -> b) -> a -> b
$ Proxy Integer -> DeclareT (Definitions Schema) Identity Schema
forall a.
ToSchema a =>
Proxy a -> DeclareT (Definitions Schema) Identity Schema
declareSchema (Proxy Integer
forall {k} (t :: k). Proxy t
Proxy :: Proxy Integer)
        let addNumberBounds Bounds {Maybe Integer
boundsLower :: Maybe Integer
boundsUpper :: Maybe Integer
boundsUpper :: forall a. Bounds a -> Maybe a
boundsLower :: forall a. Bounds a -> Maybe a
..} Schema
s_ =
              Schema
s_
                { _schemaMinimum = fromInteger <$> boundsLower,
                  _schemaMaximum = fromInteger <$> boundsUpper
                }
        pure $ NamedSchema mname $ addNumberBounds mBounds s
      NumberCodec Maybe Text
mname Bounds Scientific
mBounds -> do
        s <- DeclareT (Definitions Schema) Identity Schema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     Schema
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (HashMap Text Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DeclareT (Definitions Schema) Identity Schema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      Schema)
-> DeclareT (Definitions Schema) Identity Schema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     Schema
forall a b. (a -> b) -> a -> b
$ Proxy Scientific -> DeclareT (Definitions Schema) Identity Schema
forall a.
ToSchema a =>
Proxy a -> DeclareT (Definitions Schema) Identity Schema
declareSchema (Proxy Scientific
forall {k} (t :: k). Proxy t
Proxy :: Proxy Scientific)
        let addNumberBounds Bounds {Maybe Scientific
boundsUpper :: forall a. Bounds a -> Maybe a
boundsLower :: forall a. Bounds a -> Maybe a
boundsLower :: Maybe Scientific
boundsUpper :: Maybe Scientific
..} Schema
s_ =
              Schema
s_
                { _schemaMinimum = boundsLower,
                  _schemaMaximum = boundsUpper
                }
        pure $ NamedSchema mname $ addNumberBounds mBounds s
      ArrayOfCodec Maybe Text
mname ValueCodec input1 output1
c -> do
        itemsSchema <- ValueCodec input1 output1
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input1 output1
c
        itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema
        pure $
          NamedSchema mname $
            mempty
              { _schemaItems = Just $ OpenApiItemsObject $ _namedSchemaSchema <$> itemsSchemaRef,
                _schemaType = Just OpenApiArray
              }
      HashMapCodec JSONCodec v
c -> do
        itemsSchema <- JSONCodec v
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go JSONCodec v
c
        itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema
        pure $
          NamedSchema Nothing $
            mempty
              { _schemaType = Just OpenApiObject,
                _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef
              }
      MapCodec JSONCodec v
c -> do
        itemsSchema <- JSONCodec v
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go JSONCodec v
c
        itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema
        pure $
          NamedSchema Nothing $
            mempty
              { _schemaType = Just OpenApiObject,
                _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef
              }
      ValueCodec input output
ValueCodec ->
        NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a.
a
-> StateT
     (HashMap Text Schema) (DeclareT (Definitions Schema) Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> Schema -> NamedSchema
NamedSchema
            Maybe Text
forall a. Maybe a
Nothing
            Schema
forall a. Monoid a => a
mempty
              { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True
              }
      EqCodec value
val JSONCodec value
valCodec ->
        NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a.
a
-> StateT
     (HashMap Text Schema) (DeclareT (Definitions Schema) Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
            let jsonVal :: Value
jsonVal = JSONCodec value -> value -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia JSONCodec value
valCodec value
val
             in Schema
forall a. Monoid a => a
mempty
                  { _schemaEnum = Just [jsonVal],
                    _schemaType = Just $ case jsonVal of
                      Aeson.Object {} -> OpenApiType
OpenApiObject
                      Aeson.Array {} -> OpenApiType
OpenApiArray
                      Aeson.String {} -> OpenApiType
OpenApiString
                      Aeson.Number {} -> OpenApiType
OpenApiNumber
                      Aeson.Bool {} -> OpenApiType
OpenApiBoolean
                      Value
Aeson.Null -> OpenApiType
OpenApiNull
                  }
      BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Value oldInput oldOutput
c -> Codec Value oldInput oldOutput
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go Codec Value oldInput oldOutput
c
      ObjectOfCodec Maybe Text
mname ObjectCodec input output
oc -> do
        ss <- ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject ObjectCodec input output
oc
        pure $ NamedSchema mname $ combineObjectSchemas ss
      EitherCodec Union
u Codec Value input1 output1
c1 Codec Value input2 output2
c2 ->
        let orNull :: forall input output. ValueCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) NamedSchema
            orNull :: forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
orNull ValueCodec input output
c = do
              ns <- ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input output
c
              pure $ ns & schema . nullable ?~ True
         in case (Codec Value input1 output1
c1, Codec Value input2 output2
c2) of
              (Codec Value input1 output1
NullCodec, Codec Value input2 output2
c) -> Codec Value input2 output2
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
orNull Codec Value input2 output2
c
              (Codec Value input1 output1
c, Codec Value input2 output2
NullCodec) -> Codec Value input1 output1
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
orNull Codec Value input1 output1
c
              (Codec Value input1 output1, Codec Value input2 output2)
_ -> do
                ns1 <- Codec Value input1 output1
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go Codec Value input1 output1
c1
                ns2 <- go c2
                combineSchemasOr u ns1 ns2
      CommentCodec Text
t ValueCodec input output
c -> do
        NamedSchema mName s <- ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input output
c
        pure $ NamedSchema mName $ addDoc t s
      ReferenceCodec Text
n ValueCodec input output
c -> do
        seenSchemas <- StateT
  (HashMap Text Schema)
  (DeclareT (Definitions Schema) Identity)
  (HashMap Text Schema)
forall s (m :: * -> *). MonadState s m => m s
State.get
        case HashMap.lookup n seenSchemas of
          Maybe Schema
Nothing -> do
            existingDeclaredSchemas <- StateT
  (HashMap Text Schema)
  (DeclareT (Definitions Schema) Identity)
  (Definitions Schema)
forall d (m :: * -> *). MonadDeclare d m => m d
look

            -- Insert a dummy schema to prevent an infinite loop in recursive data structures
            let dummySchema = Schema
forall a. Monoid a => a
mempty
            let seenSchemas' = Text -> Schema -> HashMap Text Schema -> HashMap Text Schema
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
n Schema
dummySchema HashMap Text Schema
seenSchemas

            -- Run in a new isolated Declare monad so that we can get the results and override
            -- the dummy before declaring it in our main Declare monad (Declare does not allow overriding itself)
            let (newDeclaredSchemas, (namedSchema, newSeenSchemas)) = flip runDeclare existingDeclaredSchemas . flip runStateT seenSchemas' $ go c

            -- Override the dummy now we actually know what the result will be
            State.put $ HashMap.insert n (_namedSchemaSchema namedSchema) newSeenSchemas
            declare $ InsOrdHashMap.insert n (_namedSchemaSchema namedSchema) newDeclaredSchemas
            pure $ namedSchema {_namedSchemaName = Just n}
          Just Schema
s ->
            -- We've been here before recursively, just reuse the schema we've previously created
            NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a.
a
-> StateT
     (HashMap Text Schema) (DeclareT (Definitions Schema) Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      NamedSchema)
-> NamedSchema
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n) Schema
s

    goObject :: ObjectCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) [Schema]
    goObject :: forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject = \case
      RequiredKeyCodec Text
key ValueCodec input output
vs Maybe Text
mDoc -> do
        ns <- ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input output
vs
        ref <- declareSpecificNamedSchemaRef ns
        pure
          [ mempty
              { _schemaRequired = [key],
                _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaType = Just OpenApiObject
              }
          ]
      OptionalKeyCodec Text
key ValueCodec input1 output1
vs Maybe Text
mDoc -> do
        ns <- ValueCodec input1 output1
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input1 output1
vs
        ref <- declareSpecificNamedSchemaRef ns
        pure
          [ mempty
              { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaType = Just OpenApiObject
              }
          ]
      OptionalKeyWithDefaultCodec Text
key ValueCodec input input
vs input
defaultValue Maybe Text
mDoc -> do
        ns <- ValueCodec input input
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
forall input output.
ValueCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     NamedSchema
go ValueCodec input input
vs
        ref <- declareSpecificNamedSchemaRef ns
        let addDefaultToSchema Schema
propertySchema = Schema
propertySchema {_schemaDefault = Just $ toJSONVia vs defaultValue}
        pure
          [ mempty
              { _schemaProperties = [(key, addDefaultToSchema . addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaType = Just OpenApiObject
              }
          ]
      OptionalKeyWithOmittedDefaultCodec Text
key ValueCodec value value
vs value
defaultValue Maybe Text
mDoc -> ObjectCodec value value
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject (Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
optionalKeyWithDefaultCodec Text
key ValueCodec value value
vs value
defaultValue Maybe Text
mDoc)
      PureCodec output
_ -> [Schema]
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall a.
a
-> StateT
     (HashMap Text Schema) (DeclareT (Definitions Schema) Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      EitherCodec Union
u Codec Object input1 output1
oc1 Codec Object input2 output2
oc2 -> do
        s1s <- Codec Object input1 output1
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject Codec Object input1 output1
oc1
        s2s <- goObject oc2
        (: []) . _namedSchemaSchema
          <$> combineSchemasOr
            u
            (NamedSchema Nothing (combineObjectSchemas s1s))
            (NamedSchema Nothing (combineObjectSchemas s2s))
      DiscriminatedUnionCodec Text
pn input -> (Text, ObjectCodec input ())
_ HashMap Text (Text, ObjectCodec Void output)
m -> do
        let d :: Discriminator
d =
              Discriminator
                { _discriminatorPropertyName :: Text
_discriminatorPropertyName = Text
pn,
                  _discriminatorMapping :: InsOrdHashMap Text Text
_discriminatorMapping = HashMap Text Text -> InsOrdHashMap Text Text
forall k v. HashMap k v -> InsOrdHashMap k v
InsOrdHashMap.fromHashMap (HashMap Text Text -> InsOrdHashMap Text Text)
-> HashMap Text Text -> InsOrdHashMap Text Text
forall a b. (a -> b) -> a -> b
$ ((Text, ObjectCodec Void output) -> Text)
-> HashMap Text (Text, ObjectCodec Void output)
-> HashMap Text Text
forall a b. (a -> b) -> HashMap Text a -> HashMap Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, ObjectCodec Void output) -> Text
forall a b. (a, b) -> a
fst HashMap Text (Text, ObjectCodec Void output)
m
                }
            mkSchema :: Text
-> (Text, ObjectCodec Void output)
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     (Referenced Schema)
mkSchema Text
dName (Text
refName, ObjectCodec Void output
oc) = do
              s <- ObjectCodec Void Text
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject (ObjectCodec Void Text
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      [Schema])
-> ObjectCodec Void Text
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall a b. (a -> b) -> a -> b
$ ObjectCodec Void output
oc ObjectCodec Void output
-> ObjectCodec Void Text -> ObjectCodec Void Text
forall a b.
Codec Object Void a -> Codec Object Void b -> Codec Object Void b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> ValueCodec Text Text -> ObjectCodec Text Text
forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
pn (Text -> ValueCodec Text Text
literalTextCodec Text
dName) ObjectCodec Text Text -> (Void -> Text) -> ObjectCodec Void Text
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= Text -> Void -> Text
forall a b. a -> b -> a
const Text
dName)
              declareSpecificSchemaRef (Just refName) $ combineObjectSchemas s
        ss <- (Text
 -> (Text, ObjectCodec Void output)
 -> StateT
      (HashMap Text Schema)
      (DeclareT (Definitions Schema) Identity)
      (Referenced Schema))
-> HashMap Text (Text, ObjectCodec Void output)
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     (HashMap Text (Referenced Schema))
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey Text
-> (Text, ObjectCodec Void output)
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     (Referenced Schema)
mkSchema HashMap Text (Text, ObjectCodec Void output)
m
        pure
          [ mempty
              { _schemaDiscriminator = Just d,
                _schemaOneOf = Just $ Foldable.toList ss
              }
          ]
      ApCodec ObjectCodec input (output1 -> output)
oc1 ObjectCodec input output1
oc2 -> do
        ss1 <- ObjectCodec input (output1 -> output)
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject ObjectCodec input (output1 -> output)
oc1
        ss2 <- goObject oc2
        pure $ ss1 ++ ss2
      BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Object oldInput oldOutput
oc -> Codec Object oldInput oldOutput
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
forall input output.
ObjectCodec input output
-> StateT
     (HashMap Text Schema)
     (DeclareT (Definitions Schema) Identity)
     [Schema]
goObject Codec Object oldInput oldOutput
oc

    addMDoc :: Maybe Text -> Schema -> Schema
    addMDoc :: Maybe Text -> Schema -> Schema
addMDoc = (Schema -> Schema)
-> (Text -> Schema -> Schema) -> Maybe Text -> Schema -> Schema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Schema -> Schema
forall a. a -> a
id Text -> Schema -> Schema
addDoc

    addDoc :: Text -> Schema -> Schema
    addDoc :: Text -> Schema -> Schema
addDoc Text
doc Schema
s =
      Schema
s
        { _schemaDescription = case _schemaDescription s of
            Maybe Text
Nothing -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
doc
            Just Text
doc' -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
doc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
doc'
        }

    combineObjectSchemas :: [Schema] -> Schema
    combineObjectSchemas :: [Schema] -> Schema
combineObjectSchemas = [Schema] -> Schema
forall a. Monoid a => [a] -> a
mconcat

    combineSchemasOr :: (MonadDeclare (Definitions Schema) m) => Union -> NamedSchema -> NamedSchema -> m NamedSchema
    combineSchemasOr :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Union -> NamedSchema -> NamedSchema -> m NamedSchema
combineSchemasOr Union
u NamedSchema
ns1 NamedSchema
ns2 = do
      let s1 :: Schema
s1 = NamedSchema -> Schema
_namedSchemaSchema NamedSchema
ns1
      let s2 :: Schema
s2 = NamedSchema -> Schema
_namedSchemaSchema NamedSchema
ns2
      s1Ref <- (NamedSchema -> Schema)
-> Referenced NamedSchema -> Referenced Schema
forall a b. (a -> b) -> Referenced a -> Referenced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedSchema -> Schema
_namedSchemaSchema (Referenced NamedSchema -> Referenced Schema)
-> m (Referenced NamedSchema) -> m (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedSchema -> m (Referenced NamedSchema)
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
NamedSchema -> m (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
ns1
      s2Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns2
      let orLens :: Lens' Schema (Maybe [Referenced Schema])
          orLens = case Union
u of
            Union
PossiblyJointUnion -> (Maybe [Referenced Schema] -> f (Maybe [Referenced Schema]))
-> Schema -> f Schema
forall s a. HasAnyOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
anyOf
            Union
DisjointUnion -> (Maybe [Referenced Schema] -> f (Maybe [Referenced Schema]))
-> Schema -> f Schema
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf
      let prototype =
            Schema
forall a. Monoid a => a
mempty
              { _schemaAdditionalProperties = case u of
                  Union
PossiblyJointUnion -> AdditionalProperties -> Maybe AdditionalProperties
forall a. a -> Maybe a
Just (AdditionalProperties -> Maybe AdditionalProperties)
-> AdditionalProperties -> Maybe AdditionalProperties
forall a b. (a -> b) -> a -> b
$ Bool -> AdditionalProperties
AdditionalPropertiesAllowed Bool
True
                  Union
DisjointUnion -> Maybe AdditionalProperties
forall a. Maybe a
Nothing
              }
      pure $
        NamedSchema Nothing $ case (s1 ^. enum_, s2 ^. enum_) of
          -- If both schemas are enums with the same type then combine their values
          (Just [Value]
s1enums, Just [Value]
s2enums)
            | Schema
s1 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
Lens' Schema (Maybe OpenApiType)
type_ Maybe OpenApiType -> Maybe OpenApiType -> Bool
forall a. Eq a => a -> a -> Bool
== Schema
s2 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
Lens' Schema (Maybe OpenApiType)
type_ ->
                Schema
prototype
                  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
Lens' Schema (Maybe [Value])
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]
s1enums [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value]
s2enums)
                  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
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Schema
s1 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
Lens' Schema (Maybe OpenApiType)
type_
          (Maybe [Value], Maybe [Value])
_ ->
            case (Schema
s1 Schema
-> Getting
     (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
-> Maybe [Referenced Schema]
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
Lens' Schema (Maybe [Referenced Schema])
orLens, Schema
s2 Schema
-> Getting
     (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
-> Maybe [Referenced Schema]
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
Lens' Schema (Maybe [Referenced Schema])
orLens) of
              (Just [Referenced Schema]
s1s, Just [Referenced Schema]
s2s) -> Schema
prototype Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
Lens' Schema (Maybe [Referenced Schema])
orLens ((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]
s1s [Referenced Schema] -> [Referenced Schema] -> [Referenced Schema]
forall a. [a] -> [a] -> [a]
++ [Referenced Schema]
s2s)
              (Just [Referenced Schema]
s1s, Maybe [Referenced Schema]
Nothing) -> Schema
prototype Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
Lens' Schema (Maybe [Referenced Schema])
orLens ((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]
s1s [Referenced Schema] -> [Referenced Schema] -> [Referenced Schema]
forall a. [a] -> [a] -> [a]
++ [Item [Referenced Schema]
Referenced Schema
s2Ref])
              (Maybe [Referenced Schema]
Nothing, Just [Referenced Schema]
s2s) -> Schema
prototype Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
Lens' Schema (Maybe [Referenced Schema])
orLens ((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
s1Ref Referenced Schema -> [Referenced Schema] -> [Referenced Schema]
forall a. a -> [a] -> [a]
: [Referenced Schema]
s2s)
              (Maybe [Referenced Schema]
Nothing, Maybe [Referenced Schema]
Nothing) -> Schema
prototype Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
Lens' Schema (Maybe [Referenced Schema])
orLens ((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
?~ [Item [Referenced Schema]
Referenced Schema
s1Ref, Item [Referenced Schema]
Referenced Schema
s2Ref]

declareSpecificNamedSchemaRef :: (MonadDeclare (Definitions Schema) m) => OpenAPI.NamedSchema -> m (Referenced NamedSchema)
declareSpecificNamedSchemaRef :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
NamedSchema -> m (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
namedSchema =
  (Schema -> NamedSchema)
-> Referenced Schema -> Referenced NamedSchema
forall a b. (a -> b) -> Referenced a -> Referenced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Text -> Schema -> NamedSchema
NamedSchema (NamedSchema -> Maybe Text
_namedSchemaName NamedSchema
namedSchema))
    (Referenced Schema -> Referenced NamedSchema)
-> m (Referenced Schema) -> m (Referenced NamedSchema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Schema -> m (Referenced Schema)
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Maybe Text -> Schema -> m (Referenced Schema)
declareSpecificSchemaRef (NamedSchema -> Maybe Text
_namedSchemaName NamedSchema
namedSchema) (NamedSchema -> Schema
_namedSchemaSchema NamedSchema
namedSchema)

declareSpecificSchemaRef :: (MonadDeclare (Definitions Schema) m) => Maybe Text -> OpenAPI.Schema -> m (Referenced Schema)
declareSpecificSchemaRef :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Maybe Text -> Schema -> m (Referenced Schema)
declareSpecificSchemaRef Maybe Text
mName Schema
s =
  case Maybe Text
mName of
    Maybe Text
Nothing -> Referenced Schema -> m (Referenced Schema)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema -> m (Referenced Schema))
-> Referenced Schema -> m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
s
    Just Text
n -> do
      known <- (Definitions Schema -> Bool) -> m 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
n)
      when (not known) $ declare $ InsOrdHashMap.singleton n s
      pure $ Ref (Reference n)