mirror of
https://github.com/scarf-sh/tie.git
synced 2024-11-28 22:32:58 +03:00
Comply with lint workflow
This commit is contained in:
Alex Biehl
Alexander Biehl
parent
3c169d3ac3
commit
cfe90c3aa4
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user