scarf-sh/tie
1
1
Fork 0
mirror of https://github.com/scarf-sh/tie.git synced 2024-11-25 07:12:01 +03:00
Code Issues Packages Projects Releases Wiki Activity

Comply with lint workflow

Browse Source
This commit is contained in:
Alex Biehl 2024-05-28 15:10:13 +02:00 committed by Alexander Biehl
parent 3c169d3ac3
commit cfe90c3aa4
7 changed files with 778 additions and 693 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Request.template.hs
View File

@ -22,8 +22,8 @@ import qualified Data.Aeson
import qualified Data.Aeson.Types import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith) import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.Coerce (coerce) import Data.Coerce (coerce)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap

122
src/Tie/Codegen/Imports.hs
View File

@ -30,131 +30,131 @@ codegenModuleHeader moduleName =
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "BangPatterns" <+> "BangPatterns"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "DataKinds" <+> "DataKinds"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "DuplicateRecordFields" <+> "DuplicateRecordFields"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "OverloadedStrings" <+> "OverloadedStrings"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "ScopedTypeVariables" <+> "ScopedTypeVariables"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "RankNTypes" <+> "RankNTypes"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "{-#" <> "{-#"
<+> "LANGUAGE" <+> "LANGUAGE"
<+> "RecordWildCards" <+> "RecordWildCards"
<+> "#-}" <+> "#-}"
<> PP.line <> PP.line
<> "module" <> "module"
<+> PP.pretty moduleName <+> PP.pretty moduleName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Control.Applicative" <+> "Control.Applicative"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Control.Exception" <+> "Control.Exception"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Control.Monad" <+> "Control.Monad"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Control.Monad.IO.Class" <+> "Control.Monad.IO.Class"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Aeson" <+> "Data.Aeson"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Aeson.Encoding" <+> "Data.Aeson.Encoding"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Aeson.Types" <+> "Data.Aeson.Types"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Attoparsec.ByteString" <+> "Data.Attoparsec.ByteString"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.ByteString" <+> "Data.ByteString"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.List" <+> "Data.List"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.List.NonEmpty" <+> "Data.List.NonEmpty"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Map" <+> "Data.Map"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Maybe" <+> "Data.Maybe"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Text" <+> "Data.Text"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Time" <+> "Data.Time"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Data.Text.Encoding" <+> "Data.Text.Encoding"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "GHC.Float" <+> "GHC.Float"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "GHC.Int" <+> "GHC.Int"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "GHC.Records" <+> "GHC.Records"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "GHC.Types" <+> "GHC.Types"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Network.HTTP.Types" <+> "Network.HTTP.Types"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Network.Wai" <+> "Network.Wai"
<> PP.line <> PP.line
<> "import" <> "import"
<+> "qualified" <+> "qualified"
<+> "Web.HttpApiData" <+> "Web.HttpApiData"

309
src/Tie/Codegen/Operation.hs
View File

@ -48,10 +48,13 @@ codegenOperations resolver operations = do
-- TODO instead of "application" take name from openapi spec -- TODO instead of "application" take name from openapi spec
"application" "application"
<+> "::" <+> "::"
<+> "(" <> "Control.Monad.IO.Class.MonadIO" <+> "("
<+> "m" <> ")" <> "Control.Monad.IO.Class.MonadIO"
<+> "m"
<> ")"
<+> "=>" <+> "=>"
<+> "(" <> "forall" <+> "("
<> "forall"
<+> "a" <+> "a"
<+> "." <+> "."
<+> "Network.Wai.Request" <+> "Network.Wai.Request"
@ -60,7 +63,8 @@ codegenOperations resolver operations = do
<+> "a" <+> "a"
<+> "->" <+> "->"
<+> "IO" <+> "IO"
<+> "a" <> ")" <+> "a"
<> ")"
<+> "->" <+> "->"
<+> "Api" <+> "Api"
<+> "m" <+> "m"
@ -68,53 +72,56 @@ codegenOperations resolver operations = do
<+> "Network.Wai.Application" <+> "Network.Wai.Application"
<+> "->" <+> "->"
<+> "Network.Wai.Application" <+> "Network.Wai.Application"
<> PP.line <> PP.line
<> "application" <> "application"
<+> "run" <+> "run"
<+> "api" <+> "api"
<+> "notFound" <+> "notFound"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "=" <+> "="
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "case" ( "case"
<+> "Network.Wai.pathInfo" <+> "Network.Wai.pathInfo"
<+> "request" <+> "request"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.concatWith ( PP.concatWith
(\x y -> x <> PP.line <> PP.line <> y) (\x y -> x <> PP.line <> PP.line <> y)
( operationsCode ( operationsCode
++ [ "_" ++ [ "_"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 ("notFound" <+> "request" <+> "respond") <> PP.indent 4 ("notFound" <+> "request" <+> "respond")
] ]
)
) )
<> PP.line )
<> "where" <> PP.line
<> PP.line <> "where"
<> PP.indent <> PP.line
4 <> PP.indent
( "unsupportedMethod" 4
<+> "_" ( "unsupportedMethod"
<+> "=" <+> "_"
<> PP.line <+> "="
<> PP.indent <> PP.line
4 <> PP.indent
( "respond" 4
<+> "(" <> "Network.Wai.responseBuilder" ( "respond"
<+> "Network.HTTP.Types.status" <> "405" <+> "("
<+> "[]" <> "Network.Wai.responseBuilder"
<+> "mempty" <> ")" <+> "Network.HTTP.Types.status"
) <> "405"
) <+> "[]"
) <+> "mempty"
<> ")"
)
)
)
inlineablePragma = inlineablePragma =
"{-#" <+> "INLINABLE" <+> "application" <+> "#-}" "{-#" <+> "INLINABLE" <+> "application" <+> "#-}"
@ -134,10 +141,10 @@ codegenApiType resolver operations = do
<+> "=" <+> "="
<+> "Api" <+> "Api"
<+> "{" <+> "{"
<> PP.line <> PP.line
<> PP.indent 4 fieldsCode <> PP.indent 4 fieldsCode
<> PP.line <> PP.line
<> "}" <> "}"
pure dataDecl pure dataDecl
codegenApiTypeOperation :: (Monad m) => Resolver m -> Operation -> m (PP.Doc ann) codegenApiTypeOperation :: (Monad m) => Resolver m -> Operation -> m (PP.Doc ann)
@ -157,18 +164,18 @@ codegenApiTypeOperation resolver Operation {..} = do
codegenApiMemberComment summary codegenApiMemberComment summary
<> toApiMemberName name <> toApiMemberName name
<+> "::" <+> "::"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.concatWith ( PP.concatWith
(\x y -> x <+> "->" <> PP.line <> y) (\x y -> x <+> "->" <> PP.line <> y)
( paramsCode ( paramsCode
++ [ codegenRequestBodyComment body <> codegenRequestBodyType body ++ [ codegenRequestBodyComment body <> codegenRequestBodyType body
| Just body <- [requestBody] | Just body <- [requestBody]
] ]
++ ["m" <+> toApiResponseTypeName name] ++ ["m" <+> toApiResponseTypeName name]
) )
) )
where where
codegenApiMemberComment mcomment = case mcomment of codegenApiMemberComment mcomment = case mcomment of
Nothing -> mempty Nothing -> mempty
@ -222,43 +229,47 @@ codegenCallApiMember operationName path queryParams headerParams requestBody =
"run" "run"
<+> "request" <+> "request"
<+> "(" <+> "("
<> "do" <> "do"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "response" ( "response"
<+> "<-" <+> "<-"
<+> PP.hsep <+> PP.hsep
( concat ( concat
[ [toApiMemberName operationName, "api"], [ [toApiMemberName operationName, "api"],
[toParamBinder name | VariableSegment Param {name} <- path], [toParamBinder name | VariableSegment Param {name} <- path],
[toParamBinder name | Param {name} <- queryParams], [toParamBinder name | Param {name} <- queryParams],
[toParamBinder name | Param {name} <- headerParams], [toParamBinder name | Param {name} <- headerParams],
["body" | Just {} <- [requestBody]] ["body" | Just {} <- [requestBody]]
] ]
) )
<> PP.line <> PP.line
<> "Control.Monad.IO.Class.liftIO" <> "Control.Monad.IO.Class.liftIO"
<+> "(" <> "respond" <+> "("
<+> "$!" <> "respond"
<+> "(" <> "toResponse" <+> "$!"
<+> "response" <> ")" <> ")" <+> "("
) <> "toResponse"
<> PP.line <+> "response"
<> ")" <> ")"
<> ")"
)
<> PP.line
<> ")"
codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann
codegenPathGuard path continuation = codegenPathGuard path continuation =
codegenPathPattern path codegenPathPattern path
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( codegenParamsGuard ( codegenParamsGuard
codegenPathParamGuard codegenPathParamGuard
[param | VariableSegment param <- path] [param | VariableSegment param <- path]
continuation continuation
) )
codegenPathPattern :: Path -> PP.Doc ann codegenPathPattern :: Path -> PP.Doc ann
codegenPathPattern path = codegenPathPattern path =
@ -281,16 +292,16 @@ codegenMethodGuard methodBodies =
<+> "Network.Wai.requestMethod" <+> "Network.Wai.requestMethod"
<+> "request" <+> "request"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep $ ( PP.vsep $
[ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body
| (method, body) <- methodBodies | (method, body) <- methodBodies
] ]
++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x") ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x")
] ]
) )
codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann
codegenRequestBodyGuard requestBody continuation = case requestBody of codegenRequestBodyGuard requestBody continuation = case requestBody of
@ -303,8 +314,8 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of
<+> "Network.Wai.getRequestBodyChunk" <+> "Network.Wai.getRequestBodyChunk"
<+> "request" <+> "request"
<+> "in" <+> "in"
<> PP.line <> PP.line
<> PP.indent 4 ("(" <> continuation <> ")") <> PP.indent 4 ("(" <> continuation <> ")")
Just RequestBody {jsonRequestBodyContent} -> Just RequestBody {jsonRequestBodyContent} ->
let parsers = let parsers =
-- TODO support forms -- TODO support forms
@ -314,13 +325,15 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of
"[" <> PP.concatWith (\x y -> x <> "," <+> y) parsers <> "]" "[" <> PP.concatWith (\x y -> x <> "," <+> y) parsers <> "]"
in "parseRequestBody" in "parseRequestBody"
<+> parsersList <+> parsersList
<+> "(" <> "\\" <> "body" <+> "("
<> "\\"
<> "body"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
@ -343,13 +356,15 @@ codegenPathParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
codegenPathParamGuard Param {name} continuation = codegenPathParamGuard Param {name} continuation =
"pathVariable" "pathVariable"
<+> toParamBinder name <+> toParamBinder name
<+> "(" <> "\\" <> toParamBinder name <+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
@ -369,39 +384,51 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati
Just style <- codegenQueryParamStyle explode style = Just style <- codegenQueryParamStyle explode style =
(if required then "requiredQueryParameters" else "optionalQueryParameters") (if required then "requiredQueryParameters" else "optionalQueryParameters")
<+> style <+> style
<+> "\"" <> toParamName name <> "\"" <+> "\""
<+> "(" <> "\\" <> toParamBinder name <> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
| required = | required =
"requiredQueryParameter" "requiredQueryParameter"
<+> "\"" <> toParamName name <> "\"" <+> "\""
<+> "(" <> "\\" <> toParamBinder name <> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
| otherwise = | otherwise =
"optionalQueryParameter" "optionalQueryParameter"
<+> "\"" <> toParamName name <> "\"" <+> "\""
<> toParamName name
<> "\""
<+> "False" <+> "False"
<+> "(" <> "\\" <> toParamBinder name <+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
@ -409,25 +436,33 @@ codegenHeaderGuard :: Param -> PP.Doc ann -> PP.Doc ann
codegenHeaderGuard Param {name, required} continuation codegenHeaderGuard Param {name, required} continuation
| required = | required =
"requiredHeader" "requiredHeader"
<+> "\"" <> toParamName name <> "\"" <+> "\""
<+> "(" <> "\\" <> toParamBinder name <> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"
| otherwise = | otherwise =
"optionalHeader" "optionalHeader"
<+> "\"" <> toParamName name <> "\"" <+> "\""
<+> "(" <> "\\" <> toParamBinder name <> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request" <+> "request"
<+> "respond" <+> "respond"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent 4 continuation <> PP.indent 4 continuation
<> ")" <> ")"
<+> "request" <+> "request"
<+> "respond" <+> "respond"

2
src/Tie/Codegen/Request.hs
View File

@ -5,8 +5,8 @@
module Tie.Codegen.Request (codegenRequestAuxFile) where module Tie.Codegen.Request (codegenRequestAuxFile) where
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import Data.FileEmbed (embedStringFile, makeRelativeToProject) import Data.FileEmbed (embedStringFile, makeRelativeToProject)
import qualified Data.Text as Text
import Prettyprinter (Doc, hsep, vsep) import Prettyprinter (Doc, hsep, vsep)
import qualified Prettyprinter.Util as Prettyprinter import qualified Prettyprinter.Util as Prettyprinter
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)

231
src/Tie/Codegen/Response.hs
View File

@ -1,8 +1,8 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Tie.Codegen.Response module Tie.Codegen.Response
( codegenResponses, ( codegenResponses,
@ -11,10 +11,10 @@ module Tie.Codegen.Response
where where
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
import Data.List (lookup) import Data.List (lookup)
import qualified Data.Text as Text import qualified Data.Text as Text
import Network.HTTP.Media (renderHeader) import Network.HTTP.Media (renderHeader)
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
import Prettyprinter (Doc, (<+>)) import Prettyprinter (Doc, (<+>))
import qualified Prettyprinter as PP import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP import qualified Prettyprinter.Render.Text as PP
@ -90,30 +90,30 @@ codegenResponses resolver responseModuleName Operation {..} = do
decl = decl =
"data" "data"
<+> toApiResponseTypeName name <+> toApiResponseTypeName name
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep $ ( PP.vsep $
[ PP.hsep $ [ PP.hsep $
concat concat
[ [op, toApiResponseConstructorName name statusCode], [ [op, toApiResponseConstructorName name statusCode],
responseBodyType response, responseBodyType response,
responseHeaderTypes response responseHeaderTypes response
] ]
| (op, (statusCode, response)) <- zip ("=" : repeat "|") responses | (op, (statusCode, response)) <- zip ("=" : repeat "|") responses
] ]
++ [ PP.hsep $ ++ [ PP.hsep $
concat concat
[ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"], [ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"],
responseBodyType response, responseBodyType response,
responseHeaderTypes response responseHeaderTypes response
] ]
| Just response <- [defaultResponse] | Just response <- [defaultResponse]
] ]
++ [ "deriving" <+> "(" <> "Show" <> ")" ++ [ "deriving" <+> "(" <> "Show" <> ")"
| not requiresCustomShowInstance | not requiresCustomShowInstance
] ]
) )
toResponseInstance = toResponseInstance =
codegenToResponses responseModuleName name responses defaultResponse codegenToResponses responseModuleName name responses defaultResponse
@ -126,11 +126,11 @@ codegenResponses resolver responseModuleName Operation {..} = do
<+> "Show" <+> "Show"
<+> toApiResponseTypeName name <+> toApiResponseTypeName name
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\"" ( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\""
) )
pure pure
( PP.vsep $ ( PP.vsep $
@ -150,35 +150,38 @@ codegenHasStatusField operationName responses defaultResponse =
<+> toApiResponseTypeName operationName <+> toApiResponseTypeName operationName
<+> "Network.HTTP.Types.Status" <+> "Network.HTTP.Types.Status"
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep $ ( PP.vsep $
[ "getField" [ "getField"
<+> "(" <> toApiResponseConstructorName operationName statusCode <+> "("
<+> "{}" <> ")" <> toApiResponseConstructorName operationName statusCode
<+> "=" <+> "{}"
<+> "Network.HTTP.Types.status" <> PP.pretty statusCode <> ")"
| (statusCode, _response) <- responses <+> "="
] <+> "Network.HTTP.Types.status"
++ [ "getField" <> PP.pretty statusCode
<+> "(" | (statusCode, _response) <- responses
<> PP.hsep ]
( concat ++ [ "getField"
[ [toApiDefaultResponseConstructorName operationName, "status"], <+> "("
( case response of <> PP.hsep
Response {responseContent = _ : _} -> ["_"] ( concat
_ -> [] [ [toApiDefaultResponseConstructorName operationName, "status"],
), ( case response of
["_" | Header {name} <- headers] Response {responseContent = _ : _} -> ["_"]
] _ -> []
) ),
<> ")" ["_" | Header {name} <- headers]
<+> "=" ]
<+> "status" )
| Just response@Response {headers} <- [defaultResponse] <> ")"
] <+> "="
) <+> "status"
| Just response@Response {headers} <- [defaultResponse]
]
)
codegenToResponses :: codegenToResponses ::
-- | Aux. Response module name TODO make this a proper type -- | Aux. Response module name TODO make this a proper type
@ -237,14 +240,21 @@ codegenToResponses responseModuleName operationName responses defaultResponse =
] ]
optionalHeaders = optionalHeaders =
[ "[" <> "(\"" <> toParamName name <> "\"," [ "["
<> "(\""
<> toParamName name
<> "\","
<+> "Web.HttpApiData.toHeader" <+> "Web.HttpApiData.toHeader"
<+> toParamBinder name <> ")" <+> toParamBinder name
<> ")"
<+> "|" <+> "|"
<+> "Just" <+> "Just"
<+> toParamBinder name <+> toParamBinder name
<+> "<-" <+> "<-"
<+> "[" <> toParamBinder name <> "]" <> "]" <+> "["
<> toParamBinder name
<> "]"
<> "]"
| Header {name, required = False} <- headers | Header {name, required = False} <- headers
] ]
in "(" in "("
@ -265,53 +275,54 @@ codegenToResponses responseModuleName operationName responses defaultResponse =
<+> "ToResponse" <+> "ToResponse"
<+> toApiResponseTypeName operationName <+> toApiResponseTypeName operationName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep $ ( PP.vsep $
[ "toResponse" [ "toResponse"
<+> "(" <+> "("
<> PP.hsep <> PP.hsep
( concat ( concat
[ [toApiResponseConstructorName operationName statusCode], [ [toApiResponseConstructorName operationName statusCode],
bodyBinder response, bodyBinder response,
[toParamBinder name | Header {name} <- headers] [toParamBinder name | Header {name} <- headers]
] ]
) )
<> ")" <> ")"
<+> "=" <+> "="
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( waiResponse response ( waiResponse response
<+> "Network.HTTP.Types.status" <> PP.pretty statusCode <+> "Network.HTTP.Types.status"
<+> responseHeaders response <> PP.pretty statusCode
<+> bodySerialize response <+> responseHeaders response
) <+> bodySerialize response
| (statusCode, response@Response {headers}) <- responses )
] | (statusCode, response@Response {headers}) <- responses
++ [ "toResponse" ]
<+> "(" ++ [ "toResponse"
<> PP.hsep <+> "("
( concat <> PP.hsep
[ [toApiDefaultResponseConstructorName operationName, "status"], ( concat
bodyBinder response, [ [toApiDefaultResponseConstructorName operationName, "status"],
[toParamBinder name | Header {name} <- headers] bodyBinder response,
] [toParamBinder name | Header {name} <- headers]
) ]
<> ")" )
<+> "=" <> ")"
<> PP.line <+> "="
<> PP.indent <> PP.line
4 <> PP.indent
( waiResponse response 4
<+> "status" ( waiResponse response
<+> responseHeaders response <+> "status"
<+> bodySerialize response <+> responseHeaders response
) <+> bodySerialize response
| Just response@Response {headers} <- [defaultResponse] )
] | Just response@Response {headers} <- [defaultResponse]
) ]
)
in decl in decl
templateContents :: ByteString templateContents :: ByteString

792
src/Tie/Codegen/Schema.hs
View File

@ -70,7 +70,7 @@ codegenParamSchema Param {schema, required} =
| Just objectType <- isObjectType typ -> | Just objectType <- isObjectType typ ->
error "Invariant broken: ruled out by pathToPath" error "Invariant broken: ruled out by pathToPath"
| otherwise -> | otherwise ->
undefined error "Impossible"
-- | Generate code for a header -- | Generate code for a header
codegenHeaderSchema :: Header -> Doc ann codegenHeaderSchema :: Header -> Doc ann
@ -88,7 +88,7 @@ codegenHeaderSchema Header {schema, required} =
| Just objectType <- isObjectType typ -> | Just objectType <- isObjectType typ ->
error "Invariant broken: ruled out by pathToPath" error "Invariant broken: ruled out by pathToPath"
| otherwise -> | otherwise ->
undefined error "Impossible"
Nothing -> Nothing ->
error "Header without schema" error "Header without schema"
@ -159,82 +159,94 @@ codegenOneOfType getDiscriminator typName variants = do
decl = decl =
"data" "data"
<+> toOneOfDataTypeName typName <+> toOneOfDataTypeName typName
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
( [ op ( [ op
<+> variantName <+> variantName
<+> codegenFieldType variantType <+> codegenFieldType variantType
| (op, (_, variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors | (op, (_, variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors
] ]
++ [ "deriving" <+> "(" <> "Show" <> ")" ++ [ "deriving" <+> "(" <> "Show" <> ")"
] ]
) )
) )
toJson = toJson =
"instance" "instance"
<+> "Data.Aeson.ToJSON" <+> "Data.Aeson.ToJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
[ "toJSON" [ "toJSON"
<+> "(" <> variantName <+> "("
<+> "x" <> ")" <> variantName
<+> "x"
<> ")"
<+> "="
<+> "Data.Aeson.toJSON"
<+> "x"
| (_, variantName, _) <- variantConstructors
]
<> PP.line
<> PP.line
<> PP.vsep
[ "toEncoding"
<+> "("
<> variantName
<+> "x"
<> ")"
<+> "=" <+> "="
<+> "Data.Aeson.toJSON" <+> "Data.Aeson.toEncoding"
<+> "x" <+> "x"
| (_, variantName, _) <- variantConstructors | (_, variantName, _) <- variantConstructors
] ]
<> PP.line )
<> PP.line
<> PP.vsep
[ "toEncoding"
<+> "(" <> variantName
<+> "x" <> ")"
<+> "="
<+> "Data.Aeson.toEncoding"
<+> "x"
| (_, variantName, _) <- variantConstructors
]
)
fromJsonVariant :: Name -> PP.Doc ann fromJsonVariant :: Name -> PP.Doc ann
fromJsonVariant variantName fromJsonVariant variantName
| Just (property, value) <- getDiscriminator variantName = | Just (property, value) <- getDiscriminator variantName =
"(" <> "Data.Aeson.Types.withObject" "("
<+> "\"" <> toDataTypeName variantName <> "\"" <> "Data.Aeson.Types.withObject"
<+> "\""
<> toDataTypeName variantName
<> "\""
<+> "$" <+> "$"
<+> "\\" <> "o" <+> "\\"
<> "o"
<+> "->" <+> "->"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "do" ( "do"
<+> PP.align <+> PP.align
( "(" <> "\"" <> PP.pretty value <> "\"" ( "("
<+> "::" <> "\""
<+> "Data.Text.Text" <> ")" <> PP.pretty value
<+> "<-" <> "\""
<+> "o" <+> "::"
<+> "Data.Aeson..:" <+> "Data.Text.Text"
<+> "\"" <> ")"
<> PP.pretty property <+> "<-"
<> "\"" <+> "o"
<> PP.line <+> "Data.Aeson..:"
<> "Data.Aeson.parseJSON" <+> "\""
<+> "(" <> PP.pretty property
<> "Data.Aeson.Object" <> "\""
<+> "o" <> PP.line
<> ")" <> "Data.Aeson.parseJSON"
) <+> "("
) <> "Data.Aeson.Object"
<> PP.line <+> "o"
<> ")" <> ")"
)
)
<> PP.line
<> ")"
<+> "x" <+> "x"
| otherwise = | otherwise =
"Data.Aeson.parseJSON" <+> "x" "Data.Aeson.parseJSON" <+> "x"
@ -244,22 +256,22 @@ codegenOneOfType getDiscriminator typName variants = do
<+> "Data.Aeson.FromJSON" <+> "Data.Aeson.FromJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "parseJSON" ( "parseJSON"
<+> "x" <+> "x"
<+> "=" <+> "="
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.concatWith ( PP.concatWith
(\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y) (\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y)
[ "(" <> variantConstructorName <+> "<$>" <+> fromJsonVariant variantName <> ")" [ "(" <> variantConstructorName <+> "<$>" <+> fromJsonVariant variantName <> ")"
| (variantName, variantConstructorName, _variantType) <- variantConstructors | (variantName, variantConstructorName, _variantType) <- variantConstructors
] ]
) )
) )
pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson])
@ -278,67 +290,74 @@ codegenObjectType typName ObjectType {..}
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "=" <+> "="
<+> toConstructorName typName <+> toConstructorName typName
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "(" <> "Data.Map.Map" ( "("
<+> "Data.Text.Text" <> "Data.Map.Map"
<+> "(" <+> "Data.Text.Text"
<> codegenFieldType propertyType <+> "("
<> ")" <> codegenFieldType propertyType
<> ")" <> ")"
<> PP.line <> ")"
<> "deriving" <> PP.line
<+> "(" <> "Show" <> ")" <> "deriving"
) <+> "("
<> "Show"
<> ")"
)
toJson = toJson =
"instance" "instance"
<+> "Data.Aeson.ToJSON" <+> "Data.Aeson.ToJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "toJSON" ( "toJSON"
<+> "(" <> toConstructorName typName <+> "("
<+> "x" <> ")" <> toConstructorName typName
<+> "=" <+> "x"
<> PP.line <> ")"
<> PP.indent <+> "="
4 <> PP.line
( "Data.Aeson.toJSON" <+> "x" <> PP.indent
) 4
<> PP.line ( "Data.Aeson.toJSON" <+> "x"
<> PP.line )
<> "toEncoding" <> PP.line
<+> "(" <> toConstructorName typName <> PP.line
<+> "x" <> ")" <> "toEncoding"
<+> "=" <+> "("
<> PP.line <> toConstructorName typName
<> PP.indent <+> "x"
4 <> ")"
( "Data.Aeson.toEncoding" <+> "x" <+> "="
) <> PP.line
) <> PP.indent
4
( "Data.Aeson.toEncoding" <+> "x"
)
)
fromJson = fromJson =
"instance" "instance"
<+> "Data.Aeson.FromJSON" <+> "Data.Aeson.FromJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "parseJSON" ( "parseJSON"
<+> "x" <+> "x"
<+> "=" <+> "="
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( toConstructorName typName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x" ( toConstructorName typName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x"
) )
) )
in pure $ PP.vsep $ intersperse mempty [decl, toJson, fromJson] in pure $ PP.vsep $ intersperse mempty [decl, toJson, fromJson]
-- additionalProperties: $ref some other schema + required properties -- additionalProperties: $ref some other schema + required properties
| Just (AdditionalProperties propertyType) <- additionalProperties = | Just (AdditionalProperties propertyType) <- additionalProperties =
@ -357,123 +376,135 @@ codegenObjectType typName ObjectType {..}
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "=" <+> "="
<+> toConstructorName typName <+> toConstructorName typName
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "{" ( "{"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.concatWith ( PP.concatWith
(\x y -> x <> "," <> PP.line <> y) (\x y -> x <> "," <> PP.line <> y)
[ toFieldName haskellField [ toFieldName haskellField
<+> "::" <+> "::"
<+> codegenRequiredOptionalFieldType <+> codegenRequiredOptionalFieldType
(HashSet.member field requiredProperties) (HashSet.member field requiredProperties)
(codegenFieldType fieldType) (codegenFieldType fieldType)
| (field, fieldType) <- orderedProperties, | (field, fieldType) <- orderedProperties,
let haskellField = let haskellField =
HashMap.lookupDefault field field haskellFieldNames HashMap.lookupDefault field field haskellFieldNames
] ]
) )
<> PP.line <> PP.line
<> "}" <> "}"
<> PP.line <> PP.line
<> "deriving" <> "deriving"
<+> "(" <+> "("
<> "Show" <> "Show"
<> ")" <> ")"
) )
toJson = toJson =
"instance" "instance"
<+> "Data.Aeson.ToJSON" <+> "Data.Aeson.ToJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "toJSON" ( "toJSON"
<+> toConstructorName typName <+> toConstructorName typName
<+> "{..}" <+> "{..}"
<+> "=" <+> "="
<+> "Data.Aeson.object" <+> "Data.Aeson.object"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "(" <> "[" ( "("
<+> PP.align <> "["
( PP.concatWith <+> PP.align
(\x y -> x <> "," <> PP.line <> y) ( PP.concatWith
[ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName haskellField (\x y -> x <> "," <> PP.line <> y)
| (field, _) <- orderedProperties, [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName haskellField
HashSet.member field requiredProperties, | (field, _) <- orderedProperties,
let haskellField = HashSet.member field requiredProperties,
HashMap.lookupDefault field field haskellFieldNames let haskellField =
] HashMap.lookupDefault field field haskellFieldNames
) ]
<> PP.line )
<> "]" <> PP.line
<> PP.line <> "]"
<> PP.concatWith <> PP.line
(\x y -> x <> PP.line <> y) <> PP.concatWith
[ ( "++" (\x y -> x <> PP.line <> y)
<+> "[" [ ( "++"
<+> "\"" <> toJsonFieldName field <> "\"" <+> "["
<+> "Data.Aeson..=" <+> "\""
<> 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 <+> toFieldName haskellField
<+> "|" <> ")"
<+> "Just" else
"maybe"
<+> "mempty"
<+> "("
<> "Data.Aeson.Encoding.pair"
<+> "\""
<> toJsonFieldName field
<> "\""
<+> "."
<+> "Data.Aeson.toEncoding"
<> ")"
<+> toFieldName haskellField <+> toFieldName haskellField
<+> "<-" | (field, _) <- orderedProperties,
<+> "[" <> toFieldName haskellField <> "]" let haskellField =
<+> "]" HashMap.lookupDefault field field haskellFieldNames
) ]
| (field, _) <- orderedProperties, )
not (HashSet.member field requiredProperties), <> PP.line
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
<> ")"
)
)
fromOptOrReq field fromOptOrReq field
| HashSet.member field requiredProperties = "Data.Aeson..:" | HashSet.member field requiredProperties = "Data.Aeson..:"
@ -484,30 +515,33 @@ codegenObjectType typName ObjectType {..}
<+> "Data.Aeson.FromJSON" <+> "Data.Aeson.FromJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "parseJSON" ( "parseJSON"
<+> "=" <+> "="
<+> "Data.Aeson.withObject" <+> "Data.Aeson.withObject"
<+> "\"" <> toDataTypeName typName <> "\"" <+> "\""
<+> "$" <> toDataTypeName typName
<+> "\\" <> "o" <> "\""
<+> "->" <+> "$"
<> PP.line <+> "\\"
<> PP.indent <> "o"
4 <+> "->"
( toConstructorName typName <> PP.line
<> PP.line <> PP.indent
<> PP.indent 4
4 ( toConstructorName typName
( PP.vsep <> PP.line
[ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\"" <> PP.indent
| (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties 4
] ( PP.vsep
) [ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\""
) | (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties
) ]
)
)
)
in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson])
codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann
@ -585,142 +619,148 @@ codegenEnumeration typName alternatives _includeNull =
let dataDecl = let dataDecl =
"data" "data"
<+> toDataTypeName typName <+> toDataTypeName typName
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "=" ( "="
<+> PP.concatWith <+> PP.concatWith
(\x y -> x <> PP.line <> "|" <+> y) (\x y -> x <> PP.line <> "|" <+> y)
(map (toEnumConstructorName typName) alternatives) (map (toEnumConstructorName typName) alternatives)
<> PP.line <> PP.line
<> "deriving" <> "deriving"
<+> "(" <> "Eq" <> "," <+> "("
<+> "Show" <> ")" <> "Eq"
) <> ","
<+> "Show"
<> ")"
)
toJSON = toJSON =
"instance" "instance"
<+> "Data.Aeson.ToJSON" <+> "Data.Aeson.ToJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "toJSON" ( "toJSON"
<+> "x" <+> "x"
<+> "=" <+> "="
<+> "case" <+> "case"
<+> "x" <+> "x"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
[ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\""
| alt <- alternatives | alt <- alternatives
] ]
) )
<> PP.line <> PP.line
<> PP.line <> PP.line
<> "toEncoding" <> "toEncoding"
<+> "x" <+> "x"
<+> "=" <+> "="
<+> "case" <+> "case"
<+> "x" <+> "x"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
[ toEnumConstructorName typName alt <+> "->" <+> "Data.Aeson.Encoding.text" <+> "\"" <> PP.pretty alt <> "\"" [ toEnumConstructorName typName alt <+> "->" <+> "Data.Aeson.Encoding.text" <+> "\"" <> PP.pretty alt <> "\""
| alt <- alternatives | alt <- alternatives
] ]
) )
) )
fromJSON = fromJSON =
"instance" "instance"
<+> "Data.Aeson.FromJSON" <+> "Data.Aeson.FromJSON"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "parseJSON" ( "parseJSON"
<+> "=" <+> "="
<+> "Data.Aeson.withText" <+> "Data.Aeson.withText"
<+> "\"" <> toDataTypeName typName <> "\"" <+> "\""
<+> "$" <> toDataTypeName typName
<+> "\\" <> "s" <> "\""
<+> "->" <+> "$"
<> PP.line <+> "\\"
<> PP.indent <> "s"
4 <+> "->"
( "case" <> PP.line
<+> "s" <> PP.indent
<+> "of" 4
<> PP.line ( "case"
<> PP.indent <+> "s"
4 <+> "of"
( PP.vsep <> PP.line
( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt <> PP.indent
| alt <- alternatives 4
] ( PP.vsep
++ ["_" <+> "->" <+> "fail" <+> "\"invalid enum value\""] ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt
) | alt <- alternatives
) ]
) ++ ["_" <+> "->" <+> "fail" <+> "\"invalid enum value\""]
) )
)
)
)
toHttpApiData = toHttpApiData =
"instance" "instance"
<+> "Web.HttpApiData.ToHttpApiData" <+> "Web.HttpApiData.ToHttpApiData"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "toQueryParam" ( "toQueryParam"
<+> "x" <+> "x"
<+> "=" <+> "="
<+> "case" <+> "case"
<+> "x" <+> "x"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
[ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\"" [ toEnumConstructorName typName alt <+> "->" <+> "\"" <> PP.pretty alt <> "\""
| alt <- alternatives | alt <- alternatives
] ]
) )
) )
fromHttpApiData = fromHttpApiData =
"instance" "instance"
<+> "Web.HttpApiData.FromHttpApiData" <+> "Web.HttpApiData.FromHttpApiData"
<+> toDataTypeName typName <+> toDataTypeName typName
<+> "where" <+> "where"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "parseUrlPiece" ( "parseUrlPiece"
<+> "x" <+> "x"
<+> "=" <+> "="
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( "case" ( "case"
<+> "x" <+> "x"
<+> "of" <+> "of"
<> PP.line <> PP.line
<> PP.indent <> PP.indent
4 4
( PP.vsep ( PP.vsep
( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt ( [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> "pure" <+> toEnumConstructorName typName alt
| alt <- alternatives | alt <- alternatives
] ]
++ ["_" <+> "->" <+> "Left" <+> "\"invalid enum value\""] ++ ["_" <+> "->" <+> "Left" <+> "\"invalid enum value\""]
) )
) )
) )
) )
in PP.vsep in PP.vsep
( intersperse ( intersperse
mempty mempty

13
src/Tie/Type.hs
View File

@ -103,10 +103,10 @@ data BasicType
| TyInteger (Maybe IntegerFormat) | TyInteger (Maybe IntegerFormat)
| TyBoolean | TyBoolean
| TyHaskellType | TyHaskellType
-- | Haskell modules to import
[Text] [Text]
-- ^ Haskell modules to import -- | Type to insert
Text Text
-- ^ Type to insert
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data FreeFormObject ty data FreeFormObject ty
@ -277,7 +277,7 @@ schemaToType resolver schema
OpenApi.OpenApiItemsObject itemsSchemaRef -> OpenApi.OpenApiItemsObject itemsSchemaRef ->
Array <$> schemaRefToType resolver itemsSchemaRef Array <$> schemaRefToType resolver itemsSchemaRef
OpenApi.OpenApiItemsArray _itemsSchemaRefs -> OpenApi.OpenApiItemsArray _itemsSchemaRefs ->
undefined -- TODO find out what tuple schemas are error "unimplemented" -- TODO find out what tuple schemas are
| otherwise -> | otherwise ->
pure $ pure $
Array Array
@ -293,7 +293,7 @@ schemaToType resolver schema
) )
) )
OpenApi.OpenApiNull -> OpenApi.OpenApiNull ->
undefined -- TODO need a BasicType for that error "unimplemented" -- TODO need a BasicType for OpenApiNull
OpenApi.OpenApiObject -> OpenApi.OpenApiObject ->
Object <$> schemaToObjectType resolver schema Object <$> schemaToObjectType resolver schema
-- Heuristic: if the 'OpenApi.Schema' has properties attached -- Heuristic: if the 'OpenApi.Schema' has properties attached
@ -625,9 +625,8 @@ normalizeObjectType ::
normalizeObjectType assignObjectFieldTypeName assignAdditionaPropertiesTypeName objectType@ObjectType {..} = do normalizeObjectType assignObjectFieldTypeName assignAdditionaPropertiesTypeName objectType@ObjectType {..} = do
(properties, newTypes) <- runWriterT $ (properties, newTypes) <- runWriterT $
flip HashMap.traverseWithKey properties $ \fieldName fieldType -> do flip HashMap.traverseWithKey properties $ \fieldName fieldType -> do
let let haskellFieldName =
haskellFieldName = HashMap.lookupDefault fieldName fieldName haskellFieldNames
HashMap.lookupDefault fieldName fieldName haskellFieldNames
WriterT $ WriterT $
normalizeNamedType normalizeNamedType
(assignObjectFieldTypeName haskellFieldName) (assignObjectFieldTypeName haskellFieldName)