{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- | This module contains the utilities to define the data types of the response type of an operation
module OpenAPI.Generate.Response
  ( getResponseDefinitions,
  )
where

import qualified Data.Aeson as Aeson
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.PprLib hiding ((<>))
import Language.Haskell.TH.Syntax
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified OpenAPI.Generate.Doc as Doc
import OpenAPI.Generate.Internal.Operation
import OpenAPI.Generate.Internal.Util
import qualified OpenAPI.Generate.Model as Model
import qualified OpenAPI.Generate.ModelDependencies as Dep
import qualified OpenAPI.Generate.Monad as OAM
import qualified OpenAPI.Generate.OptParse as OAO
import qualified OpenAPI.Generate.Types as OAT

#if !MIN_VERSION_template_haskell(2,17,0)
examineCode :: a -> a
examineCode = id
#endif

-- | Generates a response type with a constructor for all possible response types of the operation.
--
-- Always generates an error case which is used if no other case matches.
getResponseDefinitions ::
  -- | The operation to generate the response types for
  OAT.OperationObject ->
  -- | A function which appends the passed 'Text' to the operation name and returns it
  (Text -> Text) ->
  -- | Returns the name of the reponse data type, the response transformation function and the document containing
  -- the definitions of all response types.
  OAM.Generator (Name, Q Exp, Q Doc, Dep.Models)
getResponseDefinitions :: OperationObject
-> (Text -> Text) -> Generator (Name, Q Exp, Q Doc, Models)
getResponseDefinitions OperationObject
operation Text -> Text
appendToOperationName = Text
-> Generator (Name, Q Exp, Q Doc, Models)
-> Generator (Name, Q Exp, Q Doc, Models)
forall a. Text -> Generator a -> Generator a
OAM.nested Text
"responses" (Generator (Name, Q Exp, Q Doc, Models)
 -> Generator (Name, Q Exp, Q Doc, Models))
-> Generator (Name, Q Exp, Q Doc, Models)
-> Generator (Name, Q Exp, Q Doc, Models)
forall a b. (a -> b) -> a -> b
$ do
  Bool
convertToCamelCase <- (Settings -> Bool) -> Generator Bool
forall a. (Settings -> a) -> Generator a
OAM.getSetting Settings -> Bool
OAO.settingConvertToCamelCase
  Text
responseSuffix <- (Settings -> Text) -> Generator Text
forall a. (Settings -> a) -> Generator a
OAM.getSetting Settings -> Text
OAO.settingResponseTypeSuffix
  Text
responseBodySuffix <- (Settings -> Text) -> Generator Text
forall a. (Settings -> a) -> Generator a
OAM.getSetting Settings -> Text
OAO.settingResponseBodyTypeSuffix
  let responsesObject :: ResponsesObject
responsesObject = OperationObject -> ResponsesObject
OAT.operationObjectResponses OperationObject
operation
      createBodyName :: Text -> Text
createBodyName = Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText Bool
convertToCamelCase Text -> Text
appendToOperationName (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
responseBodySuffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      createName :: Text -> Name
createName = Bool -> (Text -> Text) -> Text -> Name
createResponseName Bool
convertToCamelCase Text -> Text
appendToOperationName (Text -> Name) -> (Text -> Text) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
responseSuffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      responseName :: Name
responseName = Text -> Name
createName Text
""
      responseReferenceCases :: [ResponseReferenceCase]
responseReferenceCases = ResponsesObject -> [ResponseReferenceCase]
getStatusCodeResponseCases ResponsesObject
responsesObject [ResponseReferenceCase]
-> [ResponseReferenceCase] -> [ResponseReferenceCase]
forall a. Semigroup a => a -> a -> a
<> ResponsesObject -> [ResponseReferenceCase]
getRangeResponseCases ResponsesObject
responsesObject
  [ResponseCase]
responseCases <- [ResponseReferenceCase] -> Generator [ResponseCase]
resolveResponseReferences [ResponseReferenceCase]
responseReferenceCases
  let responseDescriptions :: [Text]
responseDescriptions = ResponseObject -> Text
getResponseDescription (ResponseObject -> Text)
-> (ResponseCase -> ResponseObject) -> ResponseCase -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Text
_, TExpQ (Status -> Bool)
_, (ResponseObject
r, [Text]
_)) -> ResponseObject
r) (ResponseCase -> Text) -> [ResponseCase] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ResponseCase]
responseCases
  [ResponseCaseDefinition]
schemas <- (Text -> Text)
-> [ResponseCase] -> Generator [ResponseCaseDefinition]
generateResponseCaseDefinitions Text -> Text
createBodyName [ResponseCase]
responseCases
  let dependencies :: Models
dependencies = [Models] -> Models
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Models] -> Models) -> [Models] -> Models
forall a b. (a -> b) -> a -> b
$ (Q Doc, Models) -> Models
forall a b. (a, b) -> b
snd ((Q Doc, Models) -> Models)
-> ((Q Type, (Q Doc, Models)) -> (Q Doc, Models))
-> (Q Type, (Q Doc, Models))
-> Models
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Type, (Q Doc, Models)) -> (Q Doc, Models)
forall a b. (a, b) -> b
snd ((Q Type, (Q Doc, Models)) -> Models)
-> [(Q Type, (Q Doc, Models))] -> [Models]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResponseCaseDefinition -> Maybe (Q Type, (Q Doc, Models)))
-> [ResponseCaseDefinition] -> [(Q Type, (Q Doc, Models))]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (\(Text
_, TExpQ (Status -> Bool)
_, Maybe (Q Type, (Q Doc, Models))
x) -> Maybe (Q Type, (Q Doc, Models))
x) [ResponseCaseDefinition]
schemas
  (Name, Q Exp, Q Doc, Models)
-> Generator (Name, Q Exp, Q Doc, Models)
forall a. a -> Generator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Q Exp, Q Doc, Models)
 -> Generator (Name, Q Exp, Q Doc, Models))
-> (Name, Q Exp, Q Doc, Models)
-> Generator (Name, Q Exp, Q Doc, Models)
forall a b. (a -> b) -> a -> b
$
    (Name
responseName,(Text -> Name) -> [ResponseCaseDefinition] -> Q Exp
createResponseTransformerFn Text -> Name
createName [ResponseCaseDefinition]
schemas,,Models
dependencies) (Q Doc -> (Name, Q Exp, Q Doc, Models))
-> Q Doc -> (Name, Q Exp, Q Doc, Models)
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Doc] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ Doc -> Q Doc
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Q Doc) -> Doc -> Q Doc
forall a b. (a -> b) -> a -> b
$
              [Text] -> Doc
Doc.generateHaddockComment
                [ Text
"Represents a response of the operation '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
appendToOperationName Text
"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'.",
                  Text
"",
                  Text
"The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), '"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText Bool
convertToCamelCase Text -> Text
appendToOperationName (Text
responseSuffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errorSuffix)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is used."
                ],
            ( Doc -> Doc -> Doc
`Doc.sideBySide`
                (String -> Doc
text String
"" Doc -> Doc -> Doc
$$ [Text] -> Doc
Doc.sideComments (Text
"Means either no matching case available or a parse error" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
responseDescriptions))
            )
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
Doc.reformatADT
              (Doc -> Doc) -> (Dec -> Doc) -> Dec -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Doc
forall a. Ppr a => a -> Doc
ppr
              (Dec -> Doc) -> Q Dec -> Q Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD
                ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
                Name
responseName
                []
                Maybe Type
forall a. Maybe a
Nothing
                ( (ResponseCaseDefinition -> Q Con)
-> [ResponseCaseDefinition] -> [Q Con]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    ( \(Text
suffix, TExpQ (Status -> Bool)
_, Maybe (Q Type, (Q Doc, Models))
maybeSchema) ->
                        Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC
                          (Text -> Name
createName Text
suffix)
                          ( case Maybe (Q Type, (Q Doc, Models))
maybeSchema of
                              Just (Q Type
type', (Q Doc, Models)
_) -> [Q Bang -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) Q Type
type']
                              Maybe (Q Type, (Q Doc, Models))
Nothing -> []
                          )
                    )
                    ((Text
errorSuffix, Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||a -> b -> a
forall a b. a -> b -> a
const Bool
True||], (Q Type, (Q Doc, Models)) -> Maybe (Q Type, (Q Doc, Models))
forall a. a -> Maybe a
Just ([t|String|], (Q Doc
forall (f :: * -> *). Applicative f => f Doc
Doc.emptyDoc, Models
forall a. Set a
Set.empty))) ResponseCaseDefinition
-> [ResponseCaseDefinition] -> [ResponseCaseDefinition]
forall a. a -> [a] -> [a]
: [ResponseCaseDefinition]
schemas)
                )
                [Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Show, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Eq]],
            [ResponseCaseDefinition] -> Q Doc
printSchemaDefinitions [ResponseCaseDefinition]
schemas
          ]

-- | First: suffix to append to the data constructor name
-- Second: an expression which can be used to determine if this case should be used in regard to the response status
-- Third: Reference or concrete response object
type ResponseReferenceCase = (Text, TExpQ (HT.Status -> Bool), OAT.Referencable OAT.ResponseObject)

-- | Same as @ResponseReferenceCase@ but with resolved reference
type ResponseCase = (Text, TExpQ (HT.Status -> Bool), (OAT.ResponseObject, [Text]))

-- | Same as @ResponseReferenceCase@ but with type definition
type ResponseCaseDefinition = (Text, TExpQ (HT.Status -> Bool), Maybe Model.TypeWithDeclaration)

-- | Suffix used for the error case
errorSuffix :: Text
errorSuffix :: Text
errorSuffix = Text
"Error"

-- | Create the name as 'Text' of the response type / data constructor based on a suffix
createResponseNameAsText :: Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText :: Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText Bool
convertToCamelCase Text -> Text
appendToOperationName = Bool -> Bool -> Text -> Text
haskellifyText Bool
convertToCamelCase Bool
True (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
appendToOperationName

-- | Create the name as 'Name' of the response type / data constructor based on a suffix
createResponseName :: Bool -> (Text -> Text) -> Text -> Name
createResponseName :: Bool -> (Text -> Text) -> Text -> Name
createResponseName Bool
convertToCamelCase Text -> Text
appendToOperationName = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText Bool
convertToCamelCase Text -> Text
appendToOperationName

-- | Generate the response cases which have a range instead of a single status code
getRangeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]
getRangeResponseCases :: ResponsesObject -> [ResponseReferenceCase]
getRangeResponseCases ResponsesObject
responsesObject =
  [Maybe ResponseReferenceCase] -> [ResponseReferenceCase]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
    [ (Text
"1XX",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||Status -> Bool
HT.statusIsInformational||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectRange1XX ResponsesObject
responsesObject,
      (Text
"2XX",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||Status -> Bool
HT.statusIsSuccessful||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectRange2XX ResponsesObject
responsesObject,
      (Text
"3XX",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||Status -> Bool
HT.statusIsRedirection||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectRange3XX ResponsesObject
responsesObject,
      (Text
"4XX",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||Status -> Bool
HT.statusIsClientError||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectRange4XX ResponsesObject
responsesObject,
      (Text
"5XX",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||Status -> Bool
HT.statusIsServerError||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectRange5XX ResponsesObject
responsesObject,
      (Text
"Default",Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||a -> b -> a
forall a b. a -> b -> a
const Bool
True||],) (Referencable ResponseObject -> ResponseReferenceCase)
-> Maybe (Referencable ResponseObject)
-> Maybe ResponseReferenceCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponsesObject -> Maybe (Referencable ResponseObject)
OAT.responsesObjectDefault ResponsesObject
responsesObject
    ]

-- | Generate the response cases based on the available status codes
getStatusCodeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]
getStatusCodeResponseCases :: ResponsesObject -> [ResponseReferenceCase]
getStatusCodeResponseCases =
  ((Int, Referencable ResponseObject) -> ResponseReferenceCase)
-> [(Int, Referencable ResponseObject)] -> [ResponseReferenceCase]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
code, Referencable ResponseObject
response) -> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
code, Code Q (Status -> Bool) -> TExpQ (Status -> Bool)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||\p
status -> Status -> Int
HT.statusCode p
status a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
code||], Referencable ResponseObject
response))
    ([(Int, Referencable ResponseObject)] -> [ResponseReferenceCase])
-> (ResponsesObject -> [(Int, Referencable ResponseObject)])
-> ResponsesObject
-> [ResponseReferenceCase]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int (Referencable ResponseObject)
-> [(Int, Referencable ResponseObject)]
forall k a. Map k a -> [(k, a)]
Map.toList
    (Map Int (Referencable ResponseObject)
 -> [(Int, Referencable ResponseObject)])
-> (ResponsesObject -> Map Int (Referencable ResponseObject))
-> ResponsesObject
-> [(Int, Referencable ResponseObject)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponsesObject -> Map Int (Referencable ResponseObject)
OAT.responsesObjectPerStatusCode

-- | Resolve the references in response cases
--
-- Note: Discards the unresolved references and generates a log message for them
resolveResponseReferences :: [ResponseReferenceCase] -> OAM.Generator [ResponseCase]
resolveResponseReferences :: [ResponseReferenceCase] -> Generator [ResponseCase]
resolveResponseReferences =
  ([Maybe ResponseCase] -> [ResponseCase])
-> Generator [Maybe ResponseCase] -> Generator [ResponseCase]
forall a b. (a -> b) -> Generator a -> Generator b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ResponseCase] -> [ResponseCase]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
    (Generator [Maybe ResponseCase] -> Generator [ResponseCase])
-> ([ResponseReferenceCase] -> Generator [Maybe ResponseCase])
-> [ResponseReferenceCase]
-> Generator [ResponseCase]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseReferenceCase -> Generator (Maybe ResponseCase))
-> [ResponseReferenceCase] -> Generator [Maybe ResponseCase]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      ( \(Text
suffix, TExpQ (Status -> Bool)
guard, Referencable ResponseObject
response) ->
          ((ResponseObject, [Text]) -> ResponseCase)
-> Maybe (ResponseObject, [Text]) -> Maybe ResponseCase
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
suffix,TExpQ (Status -> Bool)
guard,) (Maybe (ResponseObject, [Text]) -> Maybe ResponseCase)
-> Generator (Maybe (ResponseObject, [Text]))
-> Generator (Maybe ResponseCase)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Generator (Maybe (ResponseObject, [Text]))
-> Generator (Maybe (ResponseObject, [Text]))
forall a. Text -> Generator a -> Generator a
OAM.nested Text
suffix (Referencable ResponseObject
-> Generator (Maybe (ResponseObject, [Text]))
getResponseObject Referencable ResponseObject
response)
      )

-- | Generate the response definitions
--
-- If no response schema is available for a case (or with an unsupported media type), an empty data constructor is used
generateResponseCaseDefinitions :: (Text -> Text) -> [ResponseCase] -> OAM.Generator [ResponseCaseDefinition]
generateResponseCaseDefinitions :: (Text -> Text)
-> [ResponseCase] -> Generator [ResponseCaseDefinition]
generateResponseCaseDefinitions Text -> Text
createBodyName =
  (ResponseCase -> Generator ResponseCaseDefinition)
-> [ResponseCase] -> Generator [ResponseCaseDefinition]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
    ( \(Text
suffix, TExpQ (Status -> Bool)
guard, (ResponseObject
r, [Text]
path)) -> [Text]
-> Generator ResponseCaseDefinition
-> Generator ResponseCaseDefinition
forall a. [Text] -> Generator a -> Generator a
OAM.resetPath [Text]
path (Generator ResponseCaseDefinition
 -> Generator ResponseCaseDefinition)
-> Generator ResponseCaseDefinition
-> Generator ResponseCaseDefinition
forall a b. (a -> b) -> a -> b
$ do
        (Maybe Schema
responseSchema, [Text]
path') <- ResponseObject -> Generator (Maybe Schema, [Text])
getResponseSchema ResponseObject
r
        (Text
suffix,TExpQ (Status -> Bool)
guard,) (Maybe (Q Type, (Q Doc, Models)) -> ResponseCaseDefinition)
-> Generator (Maybe (Q Type, (Q Doc, Models)))
-> Generator ResponseCaseDefinition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Schema -> Generator (Q Type, (Q Doc, Models)))
-> Maybe Schema -> Generator (Maybe (Q Type, (Q Doc, Models)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ([Text]
-> Generator (Q Type, (Q Doc, Models))
-> Generator (Q Type, (Q Doc, Models))
forall a. [Text] -> Generator a -> Generator a
OAM.resetPath [Text]
path' (Generator (Q Type, (Q Doc, Models))
 -> Generator (Q Type, (Q Doc, Models)))
-> (Schema -> Generator (Q Type, (Q Doc, Models)))
-> Schema
-> Generator (Q Type, (Q Doc, Models))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Schema -> Generator (Q Type, (Q Doc, Models))
Model.defineModelForSchemaNamed (Text -> Text
createBodyName Text
suffix)) Maybe Schema
responseSchema
    )

-- | Prints the definitions of the different response case data types in 'Q'
printSchemaDefinitions :: [ResponseCaseDefinition] -> Q Doc
printSchemaDefinitions :: [ResponseCaseDefinition] -> Q Doc
printSchemaDefinitions =
  ([Doc] -> Doc) -> Q [Doc] -> Q Doc
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc] -> Doc
vcat
    (Q [Doc] -> Q Doc)
-> ([ResponseCaseDefinition] -> Q [Doc])
-> [ResponseCaseDefinition]
-> Q Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Doc] -> Q [Doc]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    ([Q Doc] -> Q [Doc])
-> ([ResponseCaseDefinition] -> [Q Doc])
-> [ResponseCaseDefinition]
-> Q [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseCaseDefinition -> Maybe (Q Doc))
-> [ResponseCaseDefinition] -> [Q Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (\(Text
_, TExpQ (Status -> Bool)
_, Maybe (Q Type, (Q Doc, Models))
namedTypeDef) -> ((Q Type, (Q Doc, Models)) -> Q Doc)
-> Maybe (Q Type, (Q Doc, Models)) -> Maybe (Q Doc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Q Doc, Models) -> Q Doc
forall a b. (a, b) -> a
fst ((Q Doc, Models) -> Q Doc)
-> ((Q Type, (Q Doc, Models)) -> (Q Doc, Models))
-> (Q Type, (Q Doc, Models))
-> Q Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Type, (Q Doc, Models)) -> (Q Doc, Models)
forall a b. (a, b) -> b
snd) Maybe (Q Type, (Q Doc, Models))
namedTypeDef)

-- | Creates a function as 'Q Exp' which can be used in the generated code to transform the response
createResponseTransformerFn :: (Text -> Name) -> [ResponseCaseDefinition] -> Q Exp
createResponseTransformerFn :: (Text -> Name) -> [ResponseCaseDefinition] -> Q Exp
createResponseTransformerFn Text -> Name
createName [ResponseCaseDefinition]
schemas =
  let responseArgName :: Name
responseArgName = String -> Name
mkName String
"response"
      bodyName :: Name
bodyName = String -> Name
mkName String
"body"
      ifCases :: Q Exp
ifCases =
        [Q (Guard, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Exp
multiIfE ([Q (Guard, Exp)] -> Q Exp) -> [Q (Guard, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$
          (ResponseCaseDefinition -> Q (Guard, Exp))
-> [ResponseCaseDefinition] -> [Q (Guard, Exp)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(Text
suffix, TExpQ (Status -> Bool)
guard, Maybe (Q Type, (Q Doc, Models))
maybeSchema) ->
                Q Exp -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE
                  [|$(TExpQ (Status -> Bool) -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
unTypeQ TExpQ (Status -> Bool)
guard) (HC.responseStatus $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
responseArgName))|]
                  ( case Maybe (Q Type, (Q Doc, Models))
maybeSchema of
                      Just (Q Type
type', (Q Doc, Models)
_) -> [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Name
createName Text
suffix) <$> (Aeson.eitherDecodeStrict $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bodyName) :: Either String $Q Type
type')|]
                      Maybe (Q Type, (Q Doc, Models))
Nothing -> [|Right $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Name
createName Text
suffix)|]
                  )
            )
            [ResponseCaseDefinition]
schemas
            [Q (Guard, Exp)] -> [Q (Guard, Exp)] -> [Q (Guard, Exp)]
forall a. Semigroup a => a -> a -> a
<> [Q Exp -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE [|otherwise|] [|Left "Missing default response type"|]]
      transformLambda :: Q Exp
transformLambda = [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
responseArgName, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
bodyName] Q Exp
ifCases
   in [|fmap (\response -> fmap (Either.either $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Name
createName Text
errorSuffix) id . $Q Exp
transformLambda response) response)|]

getResponseDescription :: OAT.ResponseObject -> Text
getResponseDescription :: ResponseObject -> Text
getResponseDescription = Text -> Text
Doc.escapeText (Text -> Text)
-> (ResponseObject -> Text) -> ResponseObject -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseObject -> Text
OAT.responseObjectDescription