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 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

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

@ -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"
@ -108,10 +112,13 @@ codegenOperations resolver operations = do
<> PP.indent
4
( "respond"
<+> "(" <> "Network.Wai.responseBuilder"
<+> "Network.HTTP.Types.status" <> "405"
<+> "("
<> "Network.Wai.responseBuilder"
<+> "Network.HTTP.Types.status"
<> "405"
<+> "[]"
<+> "mempty" <> ")"
<+> "mempty"
<> ")"
)
)
)
@ -239,10 +246,14 @@ codegenCallApiMember operationName path queryParams headerParams requestBody =
)
<> PP.line
<> "Control.Monad.IO.Class.liftIO"
<+> "(" <> "respond"
<+> "("
<> "respond"
<+> "$!"
<+> "(" <> "toResponse"
<+> "response" <> ")" <> ")"
<+> "("
<> "toResponse"
<+> "response"
<> ")"
<> ")"
)
<> PP.line
<> ")"
@ -314,7 +325,9 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of
"[" <> PP.concatWith (\x y -> x <> "," <+> y) parsers <> "]"
in "parseRequestBody"
<+> parsersList
<+> "(" <> "\\" <> "body"
<+> "("
<> "\\"
<> "body"
<+> "request"
<+> "respond"
<+> "->"
@ -343,7 +356,9 @@ codegenPathParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
codegenPathParamGuard Param {name} continuation =
"pathVariable"
<+> toParamBinder name
<+> "(" <> "\\" <> toParamBinder name
<+> "("
<> "\\"
<> toParamBinder name
<+> "request"
<+> "respond"
<+> "->"
@ -369,8 +384,12 @@ 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"
<+> "->"
@ -381,8 +400,12 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati
<+> "respond"
| required =
"requiredQueryParameter"
<+> "\"" <> toParamName name <> "\""
<+> "(" <> "\\" <> toParamBinder name
<+> "\""
<> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request"
<+> "respond"
<+> "->"
@ -393,9 +416,13 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati
<+> "respond"
| otherwise =
"optionalQueryParameter"
<+> "\"" <> toParamName name <> "\""
<+> "\""
<> toParamName name
<> "\""
<+> "False"
<+> "(" <> "\\" <> toParamBinder name
<+> "("
<> "\\"
<> toParamBinder name
<+> "request"
<+> "respond"
<+> "->"
@ -409,8 +436,12 @@ 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"
<+> "->"
@ -421,8 +452,12 @@ codegenHeaderGuard Param {name, required} continuation
<+> "respond"
| otherwise =
"optionalHeader"
<+> "\"" <> toParamName name <> "\""
<+> "(" <> "\\" <> toParamBinder name
<+> "\""
<> toParamName name
<> "\""
<+> "("
<> "\\"
<> toParamBinder name
<+> "request"
<+> "respond"
<+> "->"

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

@ -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)

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

@ -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
@ -155,10 +155,13 @@ codegenHasStatusField operationName responses defaultResponse =
4
( PP.vsep $
[ "getField"
<+> "(" <> toApiResponseConstructorName operationName statusCode
<+> "{}" <> ")"
<+> "("
<> toApiResponseConstructorName operationName statusCode
<+> "{}"
<> ")"
<+> "="
<+> "Network.HTTP.Types.status" <> PP.pretty statusCode
<+> "Network.HTTP.Types.status"
<> PP.pretty statusCode
| (statusCode, _response) <- responses
]
++ [ "getField"
@ -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 "("
@ -284,7 +294,8 @@ codegenToResponses responseModuleName operationName responses defaultResponse =
<> PP.indent
4
( waiResponse response
<+> "Network.HTTP.Types.status" <> PP.pretty statusCode
<+> "Network.HTTP.Types.status"
<> PP.pretty statusCode
<+> responseHeaders response
<+> bodySerialize response
)

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

@ -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"
@ -183,8 +183,10 @@ codegenOneOfType getDiscriminator typName variants = do
4
( PP.vsep
[ "toJSON"
<+> "(" <> variantName
<+> "x" <> ")"
<+> "("
<> variantName
<+> "x"
<> ")"
<+> "="
<+> "Data.Aeson.toJSON"
<+> "x"
@ -194,8 +196,10 @@ codegenOneOfType getDiscriminator typName variants = do
<> PP.line
<> PP.vsep
[ "toEncoding"
<+> "(" <> variantName
<+> "x" <> ")"
<+> "("
<> variantName
<+> "x"
<> ")"
<+> "="
<+> "Data.Aeson.toEncoding"
<+> "x"
@ -206,19 +210,27 @@ codegenOneOfType getDiscriminator typName variants = do
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 <> "\""
( "("
<> "\""
<> PP.pretty value
<> "\""
<+> "::"
<+> "Data.Text.Text" <> ")"
<+> "Data.Text.Text"
<> ")"
<+> "<-"
<+> "o"
<+> "Data.Aeson..:"
@ -281,7 +293,8 @@ codegenObjectType typName ObjectType {..}
<> PP.line
<> PP.indent
4
( "(" <> "Data.Map.Map"
( "("
<> "Data.Map.Map"
<+> "Data.Text.Text"
<+> "("
<> codegenFieldType propertyType
@ -289,7 +302,9 @@ codegenObjectType typName ObjectType {..}
<> ")"
<> PP.line
<> "deriving"
<+> "(" <> "Show" <> ")"
<+> "("
<> "Show"
<> ")"
)
toJson =
@ -301,8 +316,10 @@ codegenObjectType typName ObjectType {..}
<> PP.indent
4
( "toJSON"
<+> "(" <> toConstructorName typName
<+> "x" <> ")"
<+> "("
<> toConstructorName typName
<+> "x"
<> ")"
<+> "="
<> PP.line
<> PP.indent
@ -312,8 +329,10 @@ codegenObjectType typName ObjectType {..}
<> PP.line
<> PP.line
<> "toEncoding"
<+> "(" <> toConstructorName typName
<+> "x" <> ")"
<+> "("
<> toConstructorName typName
<+> "x"
<> ")"
<+> "="
<> PP.line
<> PP.indent
@ -401,7 +420,8 @@ codegenObjectType typName ObjectType {..}
<> PP.line
<> PP.indent
4
( "(" <> "["
( "("
<> "["
<+> PP.align
( PP.concatWith
(\x y -> x <> "," <> PP.line <> y)
@ -419,14 +439,18 @@ codegenObjectType typName ObjectType {..}
(\x y -> x <> PP.line <> y)
[ ( "++"
<+> "["
<+> "\"" <> toJsonFieldName field <> "\""
<+> "\""
<> toJsonFieldName field
<> "\""
<+> "Data.Aeson..="
<+> toFieldName haskellField
<+> "|"
<+> "Just"
<+> toFieldName haskellField
<+> "<-"
<+> "[" <> toFieldName haskellField <> "]"
<+> "["
<> toFieldName haskellField
<> "]"
<+> "]"
)
| (field, _) <- orderedProperties,
@ -453,17 +477,24 @@ codegenObjectType typName ObjectType {..}
[ if HashSet.member field requiredProperties
then
"Data.Aeson.Encoding.pair"
<+> "\"" <> toJsonFieldName field <> "\""
<+> "(" <> "Data.Aeson.toEncoding"
<+> toFieldName haskellField <> ")"
<+> "\""
<> toJsonFieldName field
<> "\""
<+> "("
<> "Data.Aeson.toEncoding"
<+> toFieldName haskellField
<> ")"
else
"maybe"
<+> "mempty"
<+> "("
<> "Data.Aeson.Encoding.pair"
<+> "\"" <> toJsonFieldName field <> "\""
<+> "\""
<> toJsonFieldName field
<> "\""
<+> "."
<+> "Data.Aeson.toEncoding" <> ")"
<+> "Data.Aeson.toEncoding"
<> ")"
<+> toFieldName haskellField
| (field, _) <- orderedProperties,
let haskellField =
@ -490,9 +521,12 @@ codegenObjectType typName ObjectType {..}
( "parseJSON"
<+> "="
<+> "Data.Aeson.withObject"
<+> "\"" <> toDataTypeName typName <> "\""
<+> "\""
<> toDataTypeName typName
<> "\""
<+> "$"
<+> "\\" <> "o"
<+> "\\"
<> "o"
<+> "->"
<> PP.line
<> PP.indent
@ -594,8 +628,11 @@ codegenEnumeration typName alternatives _includeNull =
(map (toEnumConstructorName typName) alternatives)
<> PP.line
<> "deriving"
<+> "(" <> "Eq" <> ","
<+> "Show" <> ")"
<+> "("
<> "Eq"
<> ","
<+> "Show"
<> ")"
)
toJSON =
"instance"
@ -647,9 +684,12 @@ codegenEnumeration typName alternatives _includeNull =
( "parseJSON"
<+> "="
<+> "Data.Aeson.withText"
<+> "\"" <> toDataTypeName typName <> "\""
<+> "\""
<> toDataTypeName typName
<> "\""
<+> "$"
<+> "\\" <> "s"
<+> "\\"
<> "s"
<+> "->"
<> PP.line
<> PP.indent

11
src/Tie/Type.hs
View File

@ -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,8 +625,7 @@ normalizeObjectType ::
normalizeObjectType assignObjectFieldTypeName assignAdditionaPropertiesTypeName objectType@ObjectType {..} = do
(properties, newTypes) <- runWriterT $
flip HashMap.traverseWithKey properties $ \fieldName fieldType -> do
let
haskellFieldName =
let haskellFieldName =
HashMap.lookupDefault fieldName fieldName haskellFieldNames
WriterT $
normalizeNamedType