From cfe90c3aa4d2c14ca8ccca239eb4d2fe9a90980c Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 28 May 2024 15:10:13 +0200 Subject: [PATCH] Comply with lint workflow --- Request.template.hs | 2 +- src/Tie/Codegen/Imports.hs | 122 +++--- src/Tie/Codegen/Operation.hs | 309 ++++++++------ src/Tie/Codegen/Request.hs | 2 +- src/Tie/Codegen/Response.hs | 231 +++++----- src/Tie/Codegen/Schema.hs | 792 ++++++++++++++++++----------------- src/Tie/Type.hs | 13 +- 7 files changed, 778 insertions(+), 693 deletions(-) diff --git a/Request.template.hs b/Request.template.hs index e558c5b..c8888bf 100644 --- a/Request.template.hs +++ b/Request.template.hs @@ -22,8 +22,8 @@ import qualified Data.Aeson import qualified Data.Aeson.Types import Data.Attoparsec.ByteString (eitherResult, parseWith) import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HashMap diff --git a/src/Tie/Codegen/Imports.hs b/src/Tie/Codegen/Imports.hs index 48cc340..813f4d2 100644 --- a/src/Tie/Codegen/Imports.hs +++ b/src/Tie/Codegen/Imports.hs @@ -30,131 +30,131 @@ codegenModuleHeader moduleName = <+> "LANGUAGE" <+> "BangPatterns" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "DataKinds" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "DuplicateRecordFields" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "OverloadedStrings" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "ScopedTypeVariables" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "RankNTypes" <+> "#-}" - <> PP.line - <> "{-#" + <> PP.line + <> "{-#" <+> "LANGUAGE" <+> "RecordWildCards" <+> "#-}" - <> PP.line - <> "module" + <> PP.line + <> "module" <+> PP.pretty moduleName <+> "where" - <> PP.line - <> PP.line - <> "import" + <> PP.line + <> PP.line + <> "import" <+> "qualified" <+> "Control.Applicative" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Control.Exception" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Control.Monad" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Control.Monad.IO.Class" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson.Encoding" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Aeson.Types" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Attoparsec.ByteString" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.ByteString" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.List" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.List.NonEmpty" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Map" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Maybe" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Text" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Time" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Data.Text.Encoding" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "GHC.Float" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "GHC.Int" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "GHC.Records" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "GHC.Types" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Network.HTTP.Types" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Network.Wai" - <> PP.line - <> "import" + <> PP.line + <> "import" <+> "qualified" <+> "Web.HttpApiData" diff --git a/src/Tie/Codegen/Operation.hs b/src/Tie/Codegen/Operation.hs index 10d5939..e513830 100644 --- a/src/Tie/Codegen/Operation.hs +++ b/src/Tie/Codegen/Operation.hs @@ -48,10 +48,13 @@ codegenOperations resolver operations = do -- TODO instead of "application" take name from openapi spec "application" <+> "::" - <+> "(" <> "Control.Monad.IO.Class.MonadIO" - <+> "m" <> ")" + <+> "(" + <> "Control.Monad.IO.Class.MonadIO" + <+> "m" + <> ")" <+> "=>" - <+> "(" <> "forall" + <+> "(" + <> "forall" <+> "a" <+> "." <+> "Network.Wai.Request" @@ -60,7 +63,8 @@ codegenOperations resolver operations = do <+> "a" <+> "->" <+> "IO" - <+> "a" <> ")" + <+> "a" + <> ")" <+> "->" <+> "Api" <+> "m" @@ -68,53 +72,56 @@ codegenOperations resolver operations = do <+> "Network.Wai.Application" <+> "->" <+> "Network.Wai.Application" - <> PP.line - <> "application" + <> PP.line + <> "application" <+> "run" <+> "api" <+> "notFound" <+> "request" <+> "respond" <+> "=" - <> PP.line - <> PP.indent - 4 - ( "case" - <+> "Network.Wai.pathInfo" - <+> "request" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.concatWith - (\x y -> x <> PP.line <> PP.line <> y) - ( operationsCode - ++ [ "_" - <+> "->" - <> PP.line - <> PP.indent 4 ("notFound" <+> "request" <+> "respond") - ] - ) + <> PP.line + <> PP.indent + 4 + ( "case" + <+> "Network.Wai.pathInfo" + <+> "request" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <> PP.line <> PP.line <> y) + ( operationsCode + ++ [ "_" + <+> "->" + <> PP.line + <> PP.indent 4 ("notFound" <+> "request" <+> "respond") + ] ) - <> PP.line - <> "where" - <> PP.line - <> PP.indent - 4 - ( "unsupportedMethod" - <+> "_" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( "respond" - <+> "(" <> "Network.Wai.responseBuilder" - <+> "Network.HTTP.Types.status" <> "405" - <+> "[]" - <+> "mempty" <> ")" - ) - ) - ) + ) + <> PP.line + <> "where" + <> PP.line + <> PP.indent + 4 + ( "unsupportedMethod" + <+> "_" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "respond" + <+> "(" + <> "Network.Wai.responseBuilder" + <+> "Network.HTTP.Types.status" + <> "405" + <+> "[]" + <+> "mempty" + <> ")" + ) + ) + ) inlineablePragma = "{-#" <+> "INLINABLE" <+> "application" <+> "#-}" @@ -134,10 +141,10 @@ codegenApiType resolver operations = do <+> "=" <+> "Api" <+> "{" - <> PP.line - <> PP.indent 4 fieldsCode - <> PP.line - <> "}" + <> PP.line + <> PP.indent 4 fieldsCode + <> PP.line + <> "}" pure dataDecl codegenApiTypeOperation :: (Monad m) => Resolver m -> Operation -> m (PP.Doc ann) @@ -157,18 +164,18 @@ codegenApiTypeOperation resolver Operation {..} = do codegenApiMemberComment summary <> toApiMemberName name <+> "::" - <> PP.line - <> PP.indent - 4 - ( PP.concatWith - (\x y -> x <+> "->" <> PP.line <> y) - ( paramsCode - ++ [ codegenRequestBodyComment body <> codegenRequestBodyType body - | Just body <- [requestBody] - ] - ++ ["m" <+> toApiResponseTypeName name] - ) - ) + <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <+> "->" <> PP.line <> y) + ( paramsCode + ++ [ codegenRequestBodyComment body <> codegenRequestBodyType body + | Just body <- [requestBody] + ] + ++ ["m" <+> toApiResponseTypeName name] + ) + ) where codegenApiMemberComment mcomment = case mcomment of Nothing -> mempty @@ -222,43 +229,47 @@ codegenCallApiMember operationName path queryParams headerParams requestBody = "run" <+> "request" <+> "(" - <> "do" - <> PP.line - <> PP.indent - 4 - ( "response" - <+> "<-" - <+> PP.hsep - ( concat - [ [toApiMemberName operationName, "api"], - [toParamBinder name | VariableSegment Param {name} <- path], - [toParamBinder name | Param {name} <- queryParams], - [toParamBinder name | Param {name} <- headerParams], - ["body" | Just {} <- [requestBody]] - ] - ) - <> PP.line - <> "Control.Monad.IO.Class.liftIO" - <+> "(" <> "respond" - <+> "$!" - <+> "(" <> "toResponse" - <+> "response" <> ")" <> ")" - ) - <> PP.line - <> ")" + <> "do" + <> PP.line + <> PP.indent + 4 + ( "response" + <+> "<-" + <+> PP.hsep + ( concat + [ [toApiMemberName operationName, "api"], + [toParamBinder name | VariableSegment Param {name} <- path], + [toParamBinder name | Param {name} <- queryParams], + [toParamBinder name | Param {name} <- headerParams], + ["body" | Just {} <- [requestBody]] + ] + ) + <> PP.line + <> "Control.Monad.IO.Class.liftIO" + <+> "(" + <> "respond" + <+> "$!" + <+> "(" + <> "toResponse" + <+> "response" + <> ")" + <> ")" + ) + <> PP.line + <> ")" codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann codegenPathGuard path continuation = codegenPathPattern path <+> "->" - <> PP.line - <> PP.indent - 4 - ( codegenParamsGuard - codegenPathParamGuard - [param | VariableSegment param <- path] - continuation - ) + <> PP.line + <> PP.indent + 4 + ( codegenParamsGuard + codegenPathParamGuard + [param | VariableSegment param <- path] + continuation + ) codegenPathPattern :: Path -> PP.Doc ann codegenPathPattern path = @@ -281,16 +292,16 @@ codegenMethodGuard methodBodies = <+> "Network.Wai.requestMethod" <+> "request" <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep $ - [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body - | (method, body) <- methodBodies - ] - ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x") - ] - ) + <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body + | (method, body) <- methodBodies + ] + ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x") + ] + ) codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann codegenRequestBodyGuard requestBody continuation = case requestBody of @@ -303,8 +314,8 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of <+> "Network.Wai.getRequestBodyChunk" <+> "request" <+> "in" - <> PP.line - <> PP.indent 4 ("(" <> continuation <> ")") + <> PP.line + <> PP.indent 4 ("(" <> continuation <> ")") Just RequestBody {jsonRequestBodyContent} -> let parsers = -- TODO support forms @@ -314,13 +325,15 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of "[" <> PP.concatWith (\x y -> x <> "," <+> y) parsers <> "]" in "parseRequestBody" <+> parsersList - <+> "(" <> "\\" <> "body" + <+> "(" + <> "\\" + <> "body" <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" @@ -343,13 +356,15 @@ codegenPathParamGuard :: Param -> PP.Doc ann -> PP.Doc ann codegenPathParamGuard Param {name} continuation = "pathVariable" <+> toParamBinder name - <+> "(" <> "\\" <> toParamBinder name + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" @@ -369,39 +384,51 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati Just style <- codegenQueryParamStyle explode style = (if required then "requiredQueryParameters" else "optionalQueryParameters") <+> style - <+> "\"" <> toParamName name <> "\"" - <+> "(" <> "\\" <> toParamBinder name + <+> "\"" + <> toParamName name + <> "\"" + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" | required = "requiredQueryParameter" - <+> "\"" <> toParamName name <> "\"" - <+> "(" <> "\\" <> toParamBinder name + <+> "\"" + <> toParamName name + <> "\"" + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" | otherwise = "optionalQueryParameter" - <+> "\"" <> toParamName name <> "\"" + <+> "\"" + <> toParamName name + <> "\"" <+> "False" - <+> "(" <> "\\" <> toParamBinder name + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" @@ -409,25 +436,33 @@ codegenHeaderGuard :: Param -> PP.Doc ann -> PP.Doc ann codegenHeaderGuard Param {name, required} continuation | required = "requiredHeader" - <+> "\"" <> toParamName name <> "\"" - <+> "(" <> "\\" <> toParamBinder name + <+> "\"" + <> toParamName name + <> "\"" + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" | otherwise = "optionalHeader" - <+> "\"" <> toParamName name <> "\"" - <+> "(" <> "\\" <> toParamBinder name + <+> "\"" + <> toParamName name + <> "\"" + <+> "(" + <> "\\" + <> toParamBinder name <+> "request" <+> "respond" <+> "->" - <> PP.line - <> PP.indent 4 continuation - <> ")" + <> PP.line + <> PP.indent 4 continuation + <> ")" <+> "request" <+> "respond" diff --git a/src/Tie/Codegen/Request.hs b/src/Tie/Codegen/Request.hs index 101bff2..fd3efbd 100644 --- a/src/Tie/Codegen/Request.hs +++ b/src/Tie/Codegen/Request.hs @@ -5,8 +5,8 @@ module Tie.Codegen.Request (codegenRequestAuxFile) where import qualified Data.ByteString as ByteString -import qualified Data.Text as Text import Data.FileEmbed (embedStringFile, makeRelativeToProject) +import qualified Data.Text as Text import Prettyprinter (Doc, hsep, vsep) import qualified Prettyprinter.Util as Prettyprinter import System.IO.Unsafe (unsafePerformIO) diff --git a/src/Tie/Codegen/Response.hs b/src/Tie/Codegen/Response.hs index c68a0dc..a48f465 100644 --- a/src/Tie/Codegen/Response.hs +++ b/src/Tie/Codegen/Response.hs @@ -1,8 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Tie.Codegen.Response ( codegenResponses, @@ -11,10 +11,10 @@ module Tie.Codegen.Response where import qualified Data.ByteString as ByteString +import Data.FileEmbed (embedStringFile, makeRelativeToProject) import Data.List (lookup) import qualified Data.Text as Text import Network.HTTP.Media (renderHeader) -import Data.FileEmbed (embedStringFile, makeRelativeToProject) import Prettyprinter (Doc, (<+>)) import qualified Prettyprinter as PP import qualified Prettyprinter.Render.Text as PP @@ -90,30 +90,30 @@ codegenResponses resolver responseModuleName Operation {..} = do decl = "data" <+> toApiResponseTypeName name - <> PP.line - <> PP.indent - 4 - ( PP.vsep $ - [ PP.hsep $ - concat - [ [op, toApiResponseConstructorName name statusCode], - responseBodyType response, - responseHeaderTypes response - ] - | (op, (statusCode, response)) <- zip ("=" : repeat "|") responses - ] - ++ [ PP.hsep $ - concat - [ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"], - responseBodyType response, - responseHeaderTypes response - ] - | Just response <- [defaultResponse] - ] - ++ [ "deriving" <+> "(" <> "Show" <> ")" - | not requiresCustomShowInstance - ] - ) + <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ PP.hsep $ + concat + [ [op, toApiResponseConstructorName name statusCode], + responseBodyType response, + responseHeaderTypes response + ] + | (op, (statusCode, response)) <- zip ("=" : repeat "|") responses + ] + ++ [ PP.hsep $ + concat + [ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"], + responseBodyType response, + responseHeaderTypes response + ] + | Just response <- [defaultResponse] + ] + ++ [ "deriving" <+> "(" <> "Show" <> ")" + | not requiresCustomShowInstance + ] + ) toResponseInstance = codegenToResponses responseModuleName name responses defaultResponse @@ -126,11 +126,11 @@ codegenResponses resolver responseModuleName Operation {..} = do <+> "Show" <+> toApiResponseTypeName name <+> "where" - <> PP.line - <> PP.indent - 4 - ( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\"" - ) + <> PP.line + <> PP.indent + 4 + ( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\"" + ) pure ( PP.vsep $ @@ -150,35 +150,38 @@ codegenHasStatusField operationName responses defaultResponse = <+> toApiResponseTypeName operationName <+> "Network.HTTP.Types.Status" <+> "where" - <> PP.line - <> PP.indent - 4 - ( PP.vsep $ - [ "getField" - <+> "(" <> toApiResponseConstructorName operationName statusCode - <+> "{}" <> ")" - <+> "=" - <+> "Network.HTTP.Types.status" <> PP.pretty statusCode - | (statusCode, _response) <- responses - ] - ++ [ "getField" - <+> "(" - <> PP.hsep - ( concat - [ [toApiDefaultResponseConstructorName operationName, "status"], - ( case response of - Response {responseContent = _ : _} -> ["_"] - _ -> [] - ), - ["_" | Header {name} <- headers] - ] - ) - <> ")" - <+> "=" - <+> "status" - | Just response@Response {headers} <- [defaultResponse] - ] - ) + <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ "getField" + <+> "(" + <> toApiResponseConstructorName operationName statusCode + <+> "{}" + <> ")" + <+> "=" + <+> "Network.HTTP.Types.status" + <> PP.pretty statusCode + | (statusCode, _response) <- responses + ] + ++ [ "getField" + <+> "(" + <> PP.hsep + ( concat + [ [toApiDefaultResponseConstructorName operationName, "status"], + ( case response of + Response {responseContent = _ : _} -> ["_"] + _ -> [] + ), + ["_" | Header {name} <- headers] + ] + ) + <> ")" + <+> "=" + <+> "status" + | Just response@Response {headers} <- [defaultResponse] + ] + ) codegenToResponses :: -- | Aux. Response module name TODO make this a proper type @@ -237,14 +240,21 @@ codegenToResponses responseModuleName operationName responses defaultResponse = ] optionalHeaders = - [ "[" <> "(\"" <> toParamName name <> "\"," + [ "[" + <> "(\"" + <> toParamName name + <> "\"," <+> "Web.HttpApiData.toHeader" - <+> toParamBinder name <> ")" + <+> toParamBinder name + <> ")" <+> "|" <+> "Just" <+> toParamBinder name <+> "<-" - <+> "[" <> toParamBinder name <> "]" <> "]" + <+> "[" + <> toParamBinder name + <> "]" + <> "]" | Header {name, required = False} <- headers ] in "(" @@ -265,53 +275,54 @@ codegenToResponses responseModuleName operationName responses defaultResponse = <+> "ToResponse" <+> toApiResponseTypeName operationName <+> "where" - <> PP.line - <> PP.indent - 4 - ( PP.vsep $ - [ "toResponse" - <+> "(" - <> PP.hsep - ( concat - [ [toApiResponseConstructorName operationName statusCode], - bodyBinder response, - [toParamBinder name | Header {name} <- headers] - ] - ) - <> ")" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( waiResponse response - <+> "Network.HTTP.Types.status" <> PP.pretty statusCode - <+> responseHeaders response - <+> bodySerialize response - ) - | (statusCode, response@Response {headers}) <- responses - ] - ++ [ "toResponse" - <+> "(" - <> PP.hsep - ( concat - [ [toApiDefaultResponseConstructorName operationName, "status"], - bodyBinder response, - [toParamBinder name | Header {name} <- headers] - ] - ) - <> ")" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( waiResponse response - <+> "status" - <+> responseHeaders response - <+> bodySerialize response - ) - | Just response@Response {headers} <- [defaultResponse] - ] - ) + <> PP.line + <> PP.indent + 4 + ( PP.vsep $ + [ "toResponse" + <+> "(" + <> PP.hsep + ( concat + [ [toApiResponseConstructorName operationName statusCode], + bodyBinder response, + [toParamBinder name | Header {name} <- headers] + ] + ) + <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( waiResponse response + <+> "Network.HTTP.Types.status" + <> PP.pretty statusCode + <+> responseHeaders response + <+> bodySerialize response + ) + | (statusCode, response@Response {headers}) <- responses + ] + ++ [ "toResponse" + <+> "(" + <> PP.hsep + ( concat + [ [toApiDefaultResponseConstructorName operationName, "status"], + bodyBinder response, + [toParamBinder name | Header {name} <- headers] + ] + ) + <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( waiResponse response + <+> "status" + <+> responseHeaders response + <+> bodySerialize response + ) + | Just response@Response {headers} <- [defaultResponse] + ] + ) in decl templateContents :: ByteString diff --git a/src/Tie/Codegen/Schema.hs b/src/Tie/Codegen/Schema.hs index 2e0a130..a967c25 100644 --- a/src/Tie/Codegen/Schema.hs +++ b/src/Tie/Codegen/Schema.hs @@ -70,7 +70,7 @@ codegenParamSchema Param {schema, required} = | Just objectType <- isObjectType typ -> error "Invariant broken: ruled out by pathToPath" | otherwise -> - undefined + error "Impossible" -- | Generate code for a header codegenHeaderSchema :: Header -> Doc ann @@ -88,7 +88,7 @@ codegenHeaderSchema Header {schema, required} = | Just objectType <- isObjectType typ -> error "Invariant broken: ruled out by pathToPath" | otherwise -> - undefined + error "Impossible" Nothing -> error "Header without schema" @@ -159,82 +159,94 @@ codegenOneOfType getDiscriminator typName variants = do decl = "data" <+> toOneOfDataTypeName typName - <> PP.line - <> PP.indent - 4 - ( PP.vsep - ( [ op - <+> variantName - <+> codegenFieldType variantType - | (op, (_, variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors - ] - ++ [ "deriving" <+> "(" <> "Show" <> ")" - ] - ) - ) + <> PP.line + <> PP.indent + 4 + ( PP.vsep + ( [ op + <+> variantName + <+> codegenFieldType variantType + | (op, (_, variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors + ] + ++ [ "deriving" <+> "(" <> "Show" <> ")" + ] + ) + ) toJson = "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - [ "toJSON" - <+> "(" <> variantName - <+> "x" <> ")" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ "toJSON" + <+> "(" + <> variantName + <+> "x" + <> ")" + <+> "=" + <+> "Data.Aeson.toJSON" + <+> "x" + | (_, variantName, _) <- variantConstructors + ] + <> PP.line + <> PP.line + <> PP.vsep + [ "toEncoding" + <+> "(" + <> variantName + <+> "x" + <> ")" <+> "=" - <+> "Data.Aeson.toJSON" + <+> "Data.Aeson.toEncoding" <+> "x" | (_, variantName, _) <- variantConstructors ] - <> PP.line - <> PP.line - <> PP.vsep - [ "toEncoding" - <+> "(" <> variantName - <+> "x" <> ")" - <+> "=" - <+> "Data.Aeson.toEncoding" - <+> "x" - | (_, variantName, _) <- variantConstructors - ] - ) + ) fromJsonVariant :: Name -> PP.Doc ann fromJsonVariant variantName | Just (property, value) <- getDiscriminator variantName = - "(" <> "Data.Aeson.Types.withObject" - <+> "\"" <> toDataTypeName variantName <> "\"" + "(" + <> "Data.Aeson.Types.withObject" + <+> "\"" + <> toDataTypeName variantName + <> "\"" <+> "$" - <+> "\\" <> "o" + <+> "\\" + <> "o" <+> "->" - <> PP.line - <> PP.indent - 4 - ( "do" - <+> PP.align - ( "(" <> "\"" <> PP.pretty value <> "\"" - <+> "::" - <+> "Data.Text.Text" <> ")" - <+> "<-" - <+> "o" - <+> "Data.Aeson..:" - <+> "\"" - <> PP.pretty property - <> "\"" - <> PP.line - <> "Data.Aeson.parseJSON" - <+> "(" - <> "Data.Aeson.Object" - <+> "o" - <> ")" - ) - ) - <> PP.line - <> ")" + <> PP.line + <> PP.indent + 4 + ( "do" + <+> PP.align + ( "(" + <> "\"" + <> PP.pretty value + <> "\"" + <+> "::" + <+> "Data.Text.Text" + <> ")" + <+> "<-" + <+> "o" + <+> "Data.Aeson..:" + <+> "\"" + <> PP.pretty property + <> "\"" + <> PP.line + <> "Data.Aeson.parseJSON" + <+> "(" + <> "Data.Aeson.Object" + <+> "o" + <> ")" + ) + ) + <> PP.line + <> ")" <+> "x" | otherwise = "Data.Aeson.parseJSON" <+> "x" @@ -244,22 +256,22 @@ codegenOneOfType getDiscriminator typName variants = do <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "parseJSON" - <+> "x" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( PP.concatWith - (\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y) - [ "(" <> variantConstructorName <+> "<$>" <+> fromJsonVariant variantName <> ")" - | (variantName, variantConstructorName, _variantType) <- variantConstructors - ] - ) - ) + <> PP.line + <> PP.indent + 4 + ( "parseJSON" + <+> "x" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y) + [ "(" <> variantConstructorName <+> "<$>" <+> fromJsonVariant variantName <> ")" + | (variantName, variantConstructorName, _variantType) <- variantConstructors + ] + ) + ) pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) @@ -278,67 +290,74 @@ codegenObjectType typName ObjectType {..} <+> toDataTypeName typName <+> "=" <+> toConstructorName typName - <> PP.line - <> PP.indent - 4 - ( "(" <> "Data.Map.Map" - <+> "Data.Text.Text" - <+> "(" - <> codegenFieldType propertyType - <> ")" - <> ")" - <> PP.line - <> "deriving" - <+> "(" <> "Show" <> ")" - ) + <> PP.line + <> PP.indent + 4 + ( "(" + <> "Data.Map.Map" + <+> "Data.Text.Text" + <+> "(" + <> codegenFieldType propertyType + <> ")" + <> ")" + <> PP.line + <> "deriving" + <+> "(" + <> "Show" + <> ")" + ) toJson = "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "toJSON" - <+> "(" <> toConstructorName typName - <+> "x" <> ")" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( "Data.Aeson.toJSON" <+> "x" - ) - <> PP.line - <> PP.line - <> "toEncoding" - <+> "(" <> toConstructorName typName - <+> "x" <> ")" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( "Data.Aeson.toEncoding" <+> "x" - ) - ) + <> PP.line + <> PP.indent + 4 + ( "toJSON" + <+> "(" + <> toConstructorName typName + <+> "x" + <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "Data.Aeson.toJSON" <+> "x" + ) + <> PP.line + <> PP.line + <> "toEncoding" + <+> "(" + <> toConstructorName typName + <+> "x" + <> ")" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "Data.Aeson.toEncoding" <+> "x" + ) + ) fromJson = "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "parseJSON" - <+> "x" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( toConstructorName typName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x" - ) - ) + <> PP.line + <> PP.indent + 4 + ( "parseJSON" + <+> "x" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( toConstructorName typName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x" + ) + ) in pure $ PP.vsep $ intersperse mempty [decl, toJson, fromJson] -- additionalProperties: $ref some other schema + required properties | Just (AdditionalProperties propertyType) <- additionalProperties = @@ -357,123 +376,135 @@ codegenObjectType typName ObjectType {..} <+> toDataTypeName typName <+> "=" <+> toConstructorName typName - <> PP.line - <> PP.indent - 4 - ( "{" - <> PP.line - <> PP.indent - 4 - ( PP.concatWith - (\x y -> x <> "," <> PP.line <> y) - [ toFieldName haskellField - <+> "::" - <+> codegenRequiredOptionalFieldType - (HashSet.member field requiredProperties) - (codegenFieldType fieldType) - | (field, fieldType) <- orderedProperties, - let haskellField = - HashMap.lookupDefault field field haskellFieldNames - ] - ) - <> PP.line - <> "}" - <> PP.line - <> "deriving" - <+> "(" - <> "Show" - <> ")" - ) + <> PP.line + <> PP.indent + 4 + ( "{" + <> PP.line + <> PP.indent + 4 + ( PP.concatWith + (\x y -> x <> "," <> PP.line <> y) + [ toFieldName haskellField + <+> "::" + <+> codegenRequiredOptionalFieldType + (HashSet.member field requiredProperties) + (codegenFieldType fieldType) + | (field, fieldType) <- orderedProperties, + let haskellField = + HashMap.lookupDefault field field haskellFieldNames + ] + ) + <> PP.line + <> "}" + <> PP.line + <> "deriving" + <+> "(" + <> "Show" + <> ")" + ) toJson = "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "toJSON" - <+> toConstructorName typName - <+> "{..}" - <+> "=" - <+> "Data.Aeson.object" - <> PP.line - <> PP.indent - 4 - ( "(" <> "[" - <+> PP.align - ( PP.concatWith - (\x y -> x <> "," <> PP.line <> y) - [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName haskellField - | (field, _) <- orderedProperties, - HashSet.member field requiredProperties, - let haskellField = - HashMap.lookupDefault field field haskellFieldNames - ] - ) - <> PP.line - <> "]" - <> PP.line - <> PP.concatWith - (\x y -> x <> PP.line <> y) - [ ( "++" - <+> "[" - <+> "\"" <> toJsonFieldName field <> "\"" - <+> "Data.Aeson..=" + <> PP.line + <> PP.indent + 4 + ( "toJSON" + <+> toConstructorName typName + <+> "{..}" + <+> "=" + <+> "Data.Aeson.object" + <> PP.line + <> PP.indent + 4 + ( "(" + <> "[" + <+> PP.align + ( PP.concatWith + (\x y -> x <> "," <> PP.line <> y) + [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName haskellField + | (field, _) <- orderedProperties, + HashSet.member field requiredProperties, + let haskellField = + HashMap.lookupDefault field field haskellFieldNames + ] + ) + <> PP.line + <> "]" + <> PP.line + <> PP.concatWith + (\x y -> x <> PP.line <> y) + [ ( "++" + <+> "[" + <+> "\"" + <> toJsonFieldName field + <> "\"" + <+> "Data.Aeson..=" + <+> toFieldName haskellField + <+> "|" + <+> "Just" + <+> toFieldName haskellField + <+> "<-" + <+> "[" + <> toFieldName haskellField + <> "]" + <+> "]" + ) + | (field, _) <- orderedProperties, + not (HashSet.member field requiredProperties), + let haskellField = + HashMap.lookupDefault field field haskellFieldNames + ] + <> ")" + ) + <> PP.line + <> PP.line + <> "toEncoding" + <+> toConstructorName typName + <+> "{..}" + <+> "=" + <+> "Data.Aeson.Encoding.pairs" + <> PP.line + <> PP.indent + 4 + ( "(" + <+> PP.align + ( PP.concatWith + (\x y -> x <+> "<>" <> PP.line <> y) + [ if HashSet.member field requiredProperties + then + "Data.Aeson.Encoding.pair" + <+> "\"" + <> toJsonFieldName field + <> "\"" + <+> "(" + <> "Data.Aeson.toEncoding" <+> toFieldName haskellField - <+> "|" - <+> "Just" + <> ")" + else + "maybe" + <+> "mempty" + <+> "(" + <> "Data.Aeson.Encoding.pair" + <+> "\"" + <> toJsonFieldName field + <> "\"" + <+> "." + <+> "Data.Aeson.toEncoding" + <> ")" <+> toFieldName haskellField - <+> "<-" - <+> "[" <> toFieldName haskellField <> "]" - <+> "]" - ) - | (field, _) <- orderedProperties, - not (HashSet.member field requiredProperties), - let haskellField = - HashMap.lookupDefault field field haskellFieldNames - ] - <> ")" - ) - <> PP.line - <> PP.line - <> "toEncoding" - <+> toConstructorName typName - <+> "{..}" - <+> "=" - <+> "Data.Aeson.Encoding.pairs" - <> PP.line - <> PP.indent - 4 - ( "(" - <+> PP.align - ( PP.concatWith - (\x y -> x <+> "<>" <> PP.line <> y) - [ if HashSet.member field requiredProperties - then - "Data.Aeson.Encoding.pair" - <+> "\"" <> toJsonFieldName field <> "\"" - <+> "(" <> "Data.Aeson.toEncoding" - <+> toFieldName haskellField <> ")" - else - "maybe" - <+> "mempty" - <+> "(" - <> "Data.Aeson.Encoding.pair" - <+> "\"" <> toJsonFieldName field <> "\"" - <+> "." - <+> "Data.Aeson.toEncoding" <> ")" - <+> toFieldName haskellField - | (field, _) <- orderedProperties, - let haskellField = - HashMap.lookupDefault field field haskellFieldNames - ] - ) - <> PP.line - <> ")" - ) - ) + | (field, _) <- orderedProperties, + let haskellField = + HashMap.lookupDefault field field haskellFieldNames + ] + ) + <> PP.line + <> ")" + ) + ) fromOptOrReq field | HashSet.member field requiredProperties = "Data.Aeson..:" @@ -484,30 +515,33 @@ codegenObjectType typName ObjectType {..} <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "parseJSON" - <+> "=" - <+> "Data.Aeson.withObject" - <+> "\"" <> toDataTypeName typName <> "\"" - <+> "$" - <+> "\\" <> "o" - <+> "->" - <> PP.line - <> PP.indent - 4 - ( toConstructorName typName - <> PP.line - <> PP.indent - 4 - ( PP.vsep - [ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\"" - | (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties - ] - ) - ) - ) + <> PP.line + <> PP.indent + 4 + ( "parseJSON" + <+> "=" + <+> "Data.Aeson.withObject" + <+> "\"" + <> toDataTypeName typName + <> "\"" + <+> "$" + <+> "\\" + <> "o" + <+> "->" + <> PP.line + <> PP.indent + 4 + ( toConstructorName typName + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\"" + | (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties + ] + ) + ) + ) in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann @@ -585,142 +619,148 @@ codegenEnumeration typName alternatives _includeNull = let dataDecl = "data" <+> toDataTypeName typName - <> PP.line - <> PP.indent - 4 - ( "=" - <+> PP.concatWith - (\x y -> x <> PP.line <> "|" <+> y) - (map (toEnumConstructorName typName) alternatives) - <> PP.line - <> "deriving" - <+> "(" <> "Eq" <> "," - <+> "Show" <> ")" - ) + <> PP.line + <> PP.indent + 4 + ( "=" + <+> PP.concatWith + (\x y -> x <> PP.line <> "|" <+> y) + (map (toEnumConstructorName typName) alternatives) + <> PP.line + <> "deriving" + <+> "(" + <> "Eq" + <> "," + <+> "Show" + <> ")" + ) toJSON = "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "toJSON" - <+> "x" - <+> "=" - <+> "case" - <+> "x" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" - | alt <- alternatives - ] - ) - <> PP.line - <> PP.line - <> "toEncoding" - <+> "x" - <+> "=" - <+> "case" - <+> "x" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - [ toEnumConstructorName typName alt <+> "->" <+> "Data.Aeson.Encoding.text" <+> "\"" <> PP.pretty alt <> "\"" - | alt <- alternatives - ] - ) - ) + <> PP.line + <> PP.indent + 4 + ( "toJSON" + <+> "x" + <+> "=" + <+> "case" + <+> "x" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" + | alt <- alternatives + ] + ) + <> PP.line + <> PP.line + <> "toEncoding" + <+> "x" + <+> "=" + <+> "case" + <+> "x" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ toEnumConstructorName typName alt <+> "->" <+> "Data.Aeson.Encoding.text" <+> "\"" <> PP.pretty alt <> "\"" + | alt <- alternatives + ] + ) + ) fromJSON = "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "parseJSON" - <+> "=" - <+> "Data.Aeson.withText" - <+> "\"" <> toDataTypeName typName <> "\"" - <+> "$" - <+> "\\" <> "s" - <+> "->" - <> PP.line - <> PP.indent - 4 - ( "case" - <+> "s" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt - | alt <- alternatives - ] - ++ ["_" <+> "->" <+> "fail" <+> "\"invalid enum value\""] - ) - ) - ) - ) + <> PP.line + <> PP.indent + 4 + ( "parseJSON" + <+> "=" + <+> "Data.Aeson.withText" + <+> "\"" + <> toDataTypeName typName + <> "\"" + <+> "$" + <+> "\\" + <> "s" + <+> "->" + <> PP.line + <> PP.indent + 4 + ( "case" + <+> "s" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt + | alt <- alternatives + ] + ++ ["_" <+> "->" <+> "fail" <+> "\"invalid enum value\""] + ) + ) + ) + ) toHttpApiData = "instance" <+> "Web.HttpApiData.ToHttpApiData" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "toQueryParam" - <+> "x" - <+> "=" - <+> "case" - <+> "x" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" - | alt <- alternatives - ] - ) - ) + <> PP.line + <> PP.indent + 4 + ( "toQueryParam" + <+> "x" + <+> "=" + <+> "case" + <+> "x" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" + | alt <- alternatives + ] + ) + ) fromHttpApiData = "instance" <+> "Web.HttpApiData.FromHttpApiData" <+> toDataTypeName typName <+> "where" - <> PP.line - <> PP.indent - 4 - ( "parseUrlPiece" - <+> "x" - <+> "=" - <> PP.line - <> PP.indent - 4 - ( "case" - <+> "x" - <+> "of" - <> PP.line - <> PP.indent - 4 - ( PP.vsep - ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt - | alt <- alternatives - ] - ++ ["_" <+> "->" <+> "Left" <+> "\"invalid enum value\""] - ) - ) - ) - ) + <> PP.line + <> PP.indent + 4 + ( "parseUrlPiece" + <+> "x" + <+> "=" + <> PP.line + <> PP.indent + 4 + ( "case" + <+> "x" + <+> "of" + <> PP.line + <> PP.indent + 4 + ( PP.vsep + ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt + | alt <- alternatives + ] + ++ ["_" <+> "->" <+> "Left" <+> "\"invalid enum value\""] + ) + ) + ) + ) in PP.vsep ( intersperse mempty diff --git a/src/Tie/Type.hs b/src/Tie/Type.hs index a77eff1..ba16b3b 100644 --- a/src/Tie/Type.hs +++ b/src/Tie/Type.hs @@ -103,10 +103,10 @@ data BasicType | TyInteger (Maybe IntegerFormat) | TyBoolean | TyHaskellType + -- | Haskell modules to import [Text] - -- ^ Haskell modules to import + -- | Type to insert Text - -- ^ Type to insert deriving (Eq, Ord, Show) data FreeFormObject ty @@ -277,7 +277,7 @@ schemaToType resolver schema OpenApi.OpenApiItemsObject itemsSchemaRef -> Array <$> schemaRefToType resolver itemsSchemaRef OpenApi.OpenApiItemsArray _itemsSchemaRefs -> - undefined -- TODO find out what tuple schemas are + error "unimplemented" -- TODO find out what tuple schemas are | otherwise -> pure $ Array @@ -293,7 +293,7 @@ schemaToType resolver schema ) ) OpenApi.OpenApiNull -> - undefined -- TODO need a BasicType for that + error "unimplemented" -- TODO need a BasicType for OpenApiNull OpenApi.OpenApiObject -> Object <$> schemaToObjectType resolver schema -- Heuristic: if the 'OpenApi.Schema' has properties attached @@ -625,9 +625,8 @@ normalizeObjectType :: normalizeObjectType assignObjectFieldTypeName assignAdditionaPropertiesTypeName objectType@ObjectType {..} = do (properties, newTypes) <- runWriterT $ flip HashMap.traverseWithKey properties $ \fieldName fieldType -> do - let - haskellFieldName = - HashMap.lookupDefault fieldName fieldName haskellFieldNames + let haskellFieldName = + HashMap.lookupDefault fieldName fieldName haskellFieldNames WriterT $ normalizeNamedType (assignObjectFieldTypeName haskellFieldName)