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

module Autodocodec.Swagger.Schema where

import Autodocodec
import Control.Monad
import Data.Foldable (toList)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.List
import Data.Proxy
import Data.Scientific
import Data.Swagger as Swagger
import Data.Swagger.Declare as Swagger
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 = JSONCodec value -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go JSONCodec value
c'
  where
    go :: ValueCodec input output -> Declare (Definitions Schema) NamedSchema
    go :: forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go = \case
      ValueCodec input output
NullCodec ->
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 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
              { _schemaParamSchema =
                  mempty
                    { _paramSchemaType = Just SwaggerNull
                    }
              }
      BoolCodec Maybe Text
mname -> 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 -> 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
        Schema
s <- 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 Integer -> Schema -> Schema
addNumberBounds Bounds {Maybe Integer
boundsLower :: Maybe Integer
boundsUpper :: Maybe Integer
boundsLower :: forall a. Bounds a -> Maybe a
boundsUpper :: forall a. Bounds a -> Maybe a
..} Schema
s_ =
              Schema
s_
                { _schemaParamSchema =
                    (_schemaParamSchema s_)
                      { _paramSchemaMinimum = fromInteger <$> boundsLower,
                        _paramSchemaMaximum = fromInteger <$> boundsUpper
                      }
                }
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
mname (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Bounds Integer -> Schema -> Schema
addNumberBounds Bounds Integer
mBounds Schema
s
      NumberCodec Maybe Text
mname Bounds Scientific
mBounds -> do
        Schema
s <- 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 Scientific -> Schema -> Schema
addNumberBounds Bounds {Maybe Scientific
boundsLower :: forall a. Bounds a -> Maybe a
boundsUpper :: forall a. Bounds a -> Maybe a
boundsLower :: Maybe Scientific
boundsUpper :: Maybe Scientific
..} Schema
s_ =
              Schema
s_
                { _schemaParamSchema =
                    (_schemaParamSchema s_)
                      { _paramSchemaMinimum = boundsLower,
                        _paramSchemaMaximum = boundsUpper
                      }
                }
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
mname (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Bounds Scientific -> Schema -> Schema
addNumberBounds Bounds Scientific
mBounds Schema
s
      HashMapCodec JSONCodec v
c -> do
        NamedSchema
itemsSchema <- JSONCodec v -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go JSONCodec v
c
        Referenced NamedSchema
itemsSchemaRef <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
itemsSchema
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 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
              { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef,
                _schemaParamSchema =
                  mempty
                    { _paramSchemaType = Just SwaggerObject
                    }
              }
      MapCodec JSONCodec v
c -> do
        NamedSchema
itemsSchema <- JSONCodec v -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go JSONCodec v
c
        Referenced NamedSchema
itemsSchemaRef <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
itemsSchema
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 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
              { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef,
                _schemaParamSchema =
                  mempty
                    { _paramSchemaType = Just SwaggerObject
                    }
              }
      ValueCodec input output
ValueCodec ->
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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
            Maybe Text
forall a. Maybe a
Nothing
            Schema
forall a. Monoid a => a
mempty
              { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True
              }
      ArrayOfCodec Maybe Text
mname ValueCodec input1 output1
c -> do
        NamedSchema
itemsSchema <- ValueCodec input1 output1
-> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input1 output1
c
        Referenced NamedSchema
itemsSchemaRef <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
itemsSchema
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
mname (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
            Schema
forall a. Monoid a => a
mempty
              { _schemaParamSchema =
                  mempty
                    { _paramSchemaType = Just SwaggerArray,
                      _paramSchemaItems = Just $ SwaggerItemsObject $ _namedSchemaSchema <$> itemsSchemaRef
                    }
              }
      ObjectOfCodec Maybe Text
mname ObjectCodec input output
oc -> do
        [Schema]
ss <- ObjectCodec input output -> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject ObjectCodec input output
oc
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
mname (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ [Schema] -> Schema
combineObjectSchemas [Schema]
ss
      EqCodec value
val JSONCodec value
valCodec ->
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 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
              { _schemaParamSchema = mempty {_paramSchemaEnum = Just [toJSONVia valCodec val]}
              }
      BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Value oldInput oldOutput
c -> Codec Value oldInput oldOutput
-> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go Codec Value oldInput oldOutput
c
      EitherCodec Union
u Codec Value input1 output1
c1 Codec Value input2 output2
c2 -> do
        NamedSchema
ns1 <- Codec Value input1 output1
-> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go Codec Value input1 output1
c1
        let s1 :: Schema
s1 = NamedSchema -> Schema
_namedSchemaSchema NamedSchema
ns1
        NamedSchema
ns2 <- Codec Value input2 output2
-> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go Codec Value input2 output2
c2
        let s2 :: Schema
s2 = NamedSchema -> Schema
_namedSchemaSchema NamedSchema
ns2
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
forall a. Maybe a
Nothing (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Union -> Schema -> Schema -> Schema
combineSchemaOr Union
u Schema
s1 Schema
s2
      CommentCodec Text
t ValueCodec input output
c -> do
        NamedSchema Maybe Text
mName Schema
s <- ValueCodec input output -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input output
c
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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 Maybe Text
mName (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> Schema
addDoc Text
t Schema
s
      ReferenceCodec Text
n ValueCodec input output
c -> do
        Definitions Schema
d <- DeclareT (Definitions Schema) Identity (Definitions Schema)
forall d (m :: * -> *). MonadDeclare d m => m d
look
        case Text -> Definitions Schema -> Maybe Schema
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
n Definitions Schema
d of
          Maybe Schema
Nothing -> do
            -- Insert a dummy to prevent an infinite loop.
            let dummy :: Schema
dummy = Schema
forall a. Monoid a => a
mempty
            let (Definitions Schema
d', NamedSchema
ns) = Declare (Definitions Schema) NamedSchema
-> Definitions Schema -> (Definitions Schema, NamedSchema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (ValueCodec input output -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input output
c) (Text -> Schema -> Definitions Schema -> Definitions Schema
forall k v.
(Eq k, Hashable k) =>
k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.insert Text
n Schema
dummy Definitions Schema
d)
            -- Override the dummy once we actually know what the result will be.
            Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Definitions Schema -> DeclareT (Definitions Schema) Identity ())
-> Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> Definitions Schema -> Definitions Schema
forall k v.
(Eq k, Hashable k) =>
k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.insert Text
n (NamedSchema -> Schema
_namedSchemaSchema NamedSchema
ns) Definitions Schema
d'
            NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedSchema
ns
          Just Schema
s -> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
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
n) Schema
s
    goObject :: ObjectCodec input output -> Declare (Definitions Schema) [Schema]
    goObject :: forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject = \case
      RequiredKeyCodec Text
key ValueCodec input output
vs Maybe Text
mDoc -> do
        NamedSchema
ns <- ValueCodec input output -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input output
vs
        Referenced NamedSchema
ref <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
ns
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ Schema
forall a. Monoid a => a
mempty
              { _schemaRequired = [key],
                _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}
              }
          ]
      OptionalKeyCodec Text
key ValueCodec input1 output1
vs Maybe Text
mDoc -> do
        NamedSchema
ns <- ValueCodec input1 output1
-> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input1 output1
vs
        Referenced NamedSchema
ref <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
ns
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ Schema
forall a. Monoid a => a
mempty
              { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}
              }
          ]
      OptionalKeyWithDefaultCodec Text
key ValueCodec input input
vs input
defaultValue Maybe Text
mDoc -> do
        NamedSchema
ns <- ValueCodec input input -> Declare (Definitions Schema) NamedSchema
forall input output.
ValueCodec input output -> Declare (Definitions Schema) NamedSchema
go ValueCodec input input
vs
        Referenced NamedSchema
ref <- NamedSchema
-> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef NamedSchema
ns
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ Schema
forall a. Monoid a => a
mempty
              { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],
                _schemaParamSchema =
                  mempty
                    { _paramSchemaDefault = Just $ toJSONVia vs defaultValue,
                      _paramSchemaType = Just SwaggerObject
                    }
              }
          ]
      OptionalKeyWithOmittedDefaultCodec Text
key ValueCodec value value
vs value
defaultValue Maybe Text
mDoc -> ObjectCodec value value -> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [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] -> Declare (Definitions Schema) [Schema]
forall a. a -> 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
        [Schema]
ss1 <- Codec Object input1 output1
-> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject Codec Object input1 output1
oc1
        [Schema]
ss2 <- Codec Object input2 output2
-> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject Codec Object input2 output2
oc2
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Union -> Schema -> Schema -> Schema
combineSchemaOr Union
u ([Schema] -> Schema
combineObjectSchemas [Schema]
ss1) ([Schema] -> Schema
combineObjectSchemas [Schema]
ss2)]
      DiscriminatedUnionCodec Text
pn input -> (Text, ObjectCodec input ())
_ HashMap Text (Text, ObjectCodec Void output)
m -> do
        let mkSchema :: Text
-> (Text, ObjectCodec Void output)
-> DeclareT (Definitions Schema) Identity Schema
mkSchema Text
dName (Text
_, ObjectCodec Void output
oc) =
              ([Schema] -> Schema)
-> Declare (Definitions Schema) [Schema]
-> DeclareT (Definitions Schema) Identity Schema
forall a b.
(a -> b)
-> DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Schema] -> Schema
combineObjectSchemas (Declare (Definitions Schema) [Schema]
 -> DeclareT (Definitions Schema) Identity Schema)
-> Declare (Definitions Schema) [Schema]
-> DeclareT (Definitions Schema) Identity Schema
forall a b. (a -> b) -> a -> b
$ ObjectCodec Void Text -> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject (ObjectCodec Void Text -> Declare (Definitions Schema) [Schema])
-> ObjectCodec Void Text -> Declare (Definitions Schema) [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 ValueCodec Text Text
textCodec 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)
        HashMap Text Schema
ss <- (Text
 -> (Text, ObjectCodec Void output)
 -> DeclareT (Definitions Schema) Identity Schema)
-> HashMap Text (Text, ObjectCodec Void output)
-> DeclareT (Definitions Schema) Identity (HashMap Text 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)
-> DeclareT (Definitions Schema) Identity Schema
mkSchema HashMap Text (Text, ObjectCodec Void output)
m
        let combined :: Schema
combined = case HashMap Text Schema -> [Schema]
forall a. HashMap Text a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashMap Text Schema
ss of
              [] -> Schema
forall a. Monoid a => a
mempty
              (Schema
s : [Schema]
ss') -> (Schema -> Schema -> Schema) -> Schema -> [Schema] -> Schema
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Union -> Schema -> Schema -> Schema
combineSchemaOr Union
DisjointUnion) Schema
s [Schema]
ss'
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item [Schema]
Schema
combined]
      ApCodec ObjectCodec input (output1 -> output)
oc1 ObjectCodec input output1
oc2 -> do
        [Schema]
ss1 <- ObjectCodec input (output1 -> output)
-> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject ObjectCodec input (output1 -> output)
oc1
        [Schema]
ss2 <- ObjectCodec input output1 -> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [Schema]
goObject ObjectCodec input output1
oc2
        [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Schema] -> Declare (Definitions Schema) [Schema])
-> [Schema] -> Declare (Definitions Schema) [Schema]
forall a b. (a -> b) -> a -> b
$ [Schema]
ss1 [Schema] -> [Schema] -> [Schema]
forall a. [a] -> [a] -> [a]
++ [Schema]
ss2
      BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Object oldInput oldOutput
oc -> Codec Object oldInput oldOutput
-> Declare (Definitions Schema) [Schema]
forall input output.
ObjectCodec input output -> Declare (Definitions Schema) [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
    combineSchemaOr :: Union -> Schema -> Schema -> Schema
    combineSchemaOr :: Union -> Schema -> Schema -> Schema
combineSchemaOr Union
u Schema
s1 Schema
s2 =
      let ps1 :: ParamSchema 'SwaggerKindSchema
ps1 = Schema -> ParamSchema 'SwaggerKindSchema
_schemaParamSchema Schema
s1
          ps2 :: ParamSchema 'SwaggerKindSchema
ps2 = Schema -> ParamSchema 'SwaggerKindSchema
_schemaParamSchema Schema
s2
          -- Swagger 2 doesn't support sum types so we have to work around that here.
          --
          -- We support a few cases:
          --
          --   * Enum: If both of them have the enum field set
          --   * Two obects: If both of them have the object type set.
          --
          -- If none of these cases match, we just take an overapproximation of
          -- the schema: one which lets any value through.
          overApproximation :: Schema
overApproximation =
            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
              }
       in case (,) ([Value] -> [Value] -> ([Value], [Value]))
-> Maybe [Value] -> Maybe ([Value] -> ([Value], [Value]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSchema 'SwaggerKindSchema -> Maybe [Value]
forall (t :: SwaggerKind (*)). ParamSchema t -> Maybe [Value]
_paramSchemaEnum ParamSchema 'SwaggerKindSchema
ps1 Maybe ([Value] -> ([Value], [Value]))
-> Maybe [Value] -> Maybe ([Value], [Value])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParamSchema 'SwaggerKindSchema -> Maybe [Value]
forall (t :: SwaggerKind (*)). ParamSchema t -> Maybe [Value]
_paramSchemaEnum ParamSchema 'SwaggerKindSchema
ps2 of
            (Just ([Value]
es1, [Value]
es2)) ->
              Schema
forall a. Monoid a => a
mempty
                { _schemaParamSchema =
                    mempty
                      { _paramSchemaEnum = Just $ es1 ++ es2,
                        _paramSchemaType =
                          case (,) <$> _paramSchemaType ps1 <*> _paramSchemaType ps2 of
                            Just (SwaggerType 'SwaggerKindSchema
t1, SwaggerType 'SwaggerKindSchema
t2)
                              | SwaggerType 'SwaggerKindSchema
t1 SwaggerType 'SwaggerKindSchema
-> SwaggerType 'SwaggerKindSchema -> Bool
forall a. Eq a => a -> a -> Bool
== SwaggerType 'SwaggerKindSchema
t2 -> SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
t1
                              | Bool
otherwise -> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. Maybe a
Nothing
                            Maybe
  (SwaggerType 'SwaggerKindSchema, SwaggerType 'SwaggerKindSchema)
Nothing -> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. Maybe a
Nothing
                      }
                }
            Maybe ([Value], [Value])
Nothing ->
              case (,) (SwaggerType 'SwaggerKindSchema
 -> SwaggerType 'SwaggerKindSchema
 -> (SwaggerType 'SwaggerKindSchema,
     SwaggerType 'SwaggerKindSchema))
-> Maybe (SwaggerType 'SwaggerKindSchema)
-> Maybe
     (SwaggerType 'SwaggerKindSchema
      -> (SwaggerType 'SwaggerKindSchema,
          SwaggerType 'SwaggerKindSchema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSchema 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall (t :: SwaggerKind (*)).
ParamSchema t -> Maybe (SwaggerType t)
_paramSchemaType ParamSchema 'SwaggerKindSchema
ps1 Maybe
  (SwaggerType 'SwaggerKindSchema
   -> (SwaggerType 'SwaggerKindSchema,
       SwaggerType 'SwaggerKindSchema))
-> Maybe (SwaggerType 'SwaggerKindSchema)
-> Maybe
     (SwaggerType 'SwaggerKindSchema, SwaggerType 'SwaggerKindSchema)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParamSchema 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall (t :: SwaggerKind (*)).
ParamSchema t -> Maybe (SwaggerType t)
_paramSchemaType ParamSchema 'SwaggerKindSchema
ps2 of
                Just (SwaggerType 'SwaggerKindSchema
SwaggerObject, SwaggerType 'SwaggerKindSchema
SwaggerObject) ->
                  Schema
forall a. Monoid a => a
mempty
                    { _schemaRequired = _schemaRequired s1 `intersect` _schemaRequired s2,
                      _schemaProperties = InsOrdHashMap.union (_schemaProperties s1) (_schemaProperties s2),
                      _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}
                    }
                Just (SwaggerType 'SwaggerKindSchema
a, SwaggerType 'SwaggerKindSchema
b)
                  | SwaggerType 'SwaggerKindSchema
a SwaggerType 'SwaggerKindSchema
-> SwaggerType 'SwaggerKindSchema -> Bool
forall a. Eq a => a -> a -> Bool
== SwaggerType 'SwaggerKindSchema
b -> Schema
forall a. Monoid a => a
mempty {_schemaParamSchema = mempty {_paramSchemaType = Just a}}
                  | Bool
otherwise -> Schema
overApproximation
                Maybe
  (SwaggerType 'SwaggerKindSchema, SwaggerType 'SwaggerKindSchema)
_ -> Schema
overApproximation

declareSpecificNamedSchemaRef :: Swagger.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)
declareSpecificNamedSchemaRef :: NamedSchema
-> Declare (Definitions Schema) (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)
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
-> Declare (Definitions Schema) (Referenced NamedSchema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
declareSpecificSchemaRef (NamedSchema -> Maybe Text
_namedSchemaName NamedSchema
namedSchema) (NamedSchema -> Schema
_namedSchemaSchema NamedSchema
namedSchema)

declareSpecificSchemaRef :: Maybe Text -> Swagger.Schema -> Declare (Definitions Schema) (Referenced Schema)
declareSpecificSchemaRef :: Maybe Text
-> Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
declareSpecificSchemaRef Maybe Text
mName Schema
s =
  case Maybe Text
mName of
    Maybe Text
Nothing -> Referenced Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema
 -> DeclareT (Definitions Schema) Identity (Referenced Schema))
-> Referenced Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
s
    Just Text
n -> do
      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
n)
      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
$ Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Definitions Schema -> DeclareT (Definitions Schema) Identity ())
-> Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> Definitions Schema
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Text
n Schema
s
      Referenced Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema
 -> DeclareT (Definitions Schema) Identity (Referenced Schema))
-> Referenced Schema
-> DeclareT (Definitions Schema) Identity (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Reference -> Referenced Schema
forall a. Reference -> Referenced a
Ref (Text -> Reference
Reference Text
n)