diff --git a/src/Tie.hs b/src/Tie.hs index 135e922..7501098 100644 --- a/src/Tie.hs +++ b/src/Tie.hs @@ -49,6 +49,7 @@ import Tie.Name import Tie.Operation ( Operation (..), errors, + normalizeOperation, operationResponseDependencies, operationSchemaDependencies, pathItemsToOperation, @@ -185,19 +186,24 @@ generate write packageName apiName inputFile = do for_ operations $ \operation@Operation {name} -> do let path = toResponseHaskellFileName apiName name header = codegenModuleHeader (toResponseHaskellModuleName apiName name) - - dependencyCode = + importsCode = codegenSchemaDependencies apiName $ nubOrd (operationSchemaDependencies shallow operation) + (operation, inlineDefinitions) <- + normalizeOperation operation + codeForInlineDefinitions <- + traverse (uncurry codegenSchema) inlineDefinitions responsesCode <- codegenResponses resolver operation write path $ vsep [ header, mempty, - dependencyCode, + importsCode, mempty, codegenExtraResponseModuleDependencies apiName, mempty, + vsep codeForInlineDefinitions, + mempty, responsesCode ] diff --git a/src/Tie/Name.hs b/src/Tie/Name.hs index 29fa7f4..d02b121 100644 --- a/src/Tie/Name.hs +++ b/src/Tie/Name.hs @@ -35,6 +35,9 @@ module Tie.Name inlineObjectTypeName, inlineVariantTypeName, inlineArrayElementTypeName, + operationParamTypeName, + apiResponseConstructorName, + apiDefaultResponseConstructorName, ) where @@ -85,7 +88,7 @@ toSchemaHaskellFileName apiName (Name name) = haskellModuleToFilePath apiName <> "/Schemas/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" haskellModuleToFilePath :: ApiName -> FilePath -haskellModuleToFilePath = +haskellModuleToFilePath = Text.unpack . Text.replace "." "/" toOperationHaskellModuleName :: ApiName -> Name -> Text @@ -146,6 +149,15 @@ toParamBinder :: Name -> PP.Doc ann toParamBinder = PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName +operationParamTypeName :: Name -> Name -> Name +operationParamTypeName (Name operationName) (Name paramName) = + Name $ + Text.pack $ + escapeKeyword $ + capitalizeFirstLetter (Text.unpack operationName) + <> capitalizeFirstLetter (Text.unpack paramName) + <> "Param" + toApiMemberName :: Name -> PP.Doc ann toApiMemberName = PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName @@ -158,10 +170,18 @@ toApiResponseConstructorName :: Name -> Int -> PP.Doc ann toApiResponseConstructorName name statusCode = PP.pretty . Text.pack . escapeKeyword . (<> show statusCode) . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName $ name +apiResponseConstructorName :: Name -> Int -> Name +apiResponseConstructorName name statusCode = + Name . Text.pack . escapeKeyword . (<> show statusCode) . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName $ name + toApiDefaultResponseConstructorName :: Name -> PP.Doc ann toApiDefaultResponseConstructorName name = PP.pretty . Text.pack . escapeKeyword . (<> "DefaultResponse") . capitalizeFirstLetter . Text.unpack . unName $ name +apiDefaultResponseConstructorName :: Name -> Name +apiDefaultResponseConstructorName name = + Name . Text.pack . escapeKeyword . (<> "DefaultResponse") . capitalizeFirstLetter . Text.unpack . unName $ name + toEnumConstructorName :: Name -> Text -> PP.Doc ann toEnumConstructorName (Name typName) variant = PP.pretty $ diff --git a/src/Tie/Operation.hs b/src/Tie/Operation.hs index 9c72c9a..30cc55b 100644 --- a/src/Tie/Operation.hs +++ b/src/Tie/Operation.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Tie.Operation ( StatusCode, @@ -28,13 +29,23 @@ module Tie.Operation -- * Dependencies operationSchemaDependencies, operationResponseDependencies, + + -- * Normalization + normalizeOperation, ) where +import Control.Monad.Writer (WriterT (..), runWriterT) import qualified Data.HashMap.Strict.InsOrd as InsOrd import qualified Data.OpenApi as OpenApi import qualified Data.Text as Text -import Tie.Name (Name, fromText) +import Tie.Name + ( Name, + apiDefaultResponseConstructorName, + apiResponseConstructorName, + fromText, + operationParamTypeName, + ) import Tie.Resolve (Resolver, resolve) import Tie.Type ( Named, @@ -42,6 +53,7 @@ import Tie.Type isBasicType, namedType, namedTypeDependencies, + normalizeNamedType, schemaRefToType, ) import Prelude hiding (Type) @@ -366,3 +378,41 @@ pathToPath resolver errors@Errors {..} textualPath params = do (isBasicType (namedType (schema param))) paramNotBasicType pure param + +normalizeParam :: Monad m => Name -> Param -> m (Param, [(Name, Type)]) +normalizeParam operationName param@Param {..} = do + (normedType, inlineDefinitions) <- + normalizeNamedType + (pure (operationParamTypeName operationName name)) + schema + pure (param {schema = normedType}, inlineDefinitions) + +normalizeResponse :: Monad m => Name -> Response -> m (Response, [(Name, Type)]) +normalizeResponse name response@Response {..} = do + (normedType, inlineDefinitions) <- normalizeNamedType (pure name) jsonResponseContent + pure (response {jsonResponseContent = normedType}, inlineDefinitions) + +normalizeOperation :: Monad m => Operation -> m (Operation, [(Name, Type)]) +normalizeOperation operation@Operation {..} = runWriterT $ do + queryParams <- + traverse + (WriterT . normalizeParam name) + queryParams + headerParams <- + traverse + (WriterT . normalizeParam name) + headerParams + defaultResponse <- + traverse + (WriterT . normalizeResponse (apiDefaultResponseConstructorName name)) + defaultResponse + responses <- + traverse + ( \(status, response) -> + ( (status,) + <$> WriterT + (normalizeResponse (apiResponseConstructorName name status) response) + ) + ) + responses + pure Operation {..} diff --git a/src/Tie/Type.hs b/src/Tie/Type.hs index d51f825..6e14f51 100644 --- a/src/Tie/Type.hs +++ b/src/Tie/Type.hs @@ -28,10 +28,8 @@ module Tie.Type isOneOfType, -- * Normalize types - - -- normalizeObjectType, - -- normalizeVariants, normalizeType, + normalizeNamedType, -- * Dependencies namedTypeDependencies, diff --git a/test/golden/datetime.yaml.out b/test/golden/datetime.yaml.out index 59eb5a3..5bc1ec9 100644 --- a/test/golden/datetime.yaml.out +++ b/test/golden/datetime.yaml.out @@ -115,6 +115,8 @@ import Test.Schemas.Test import Test.Response + + data TestResponse = TestResponse200 Test diff --git a/test/golden/enum.yaml.out b/test/golden/enum.yaml.out index 59539ac..7c6223f 100644 --- a/test/golden/enum.yaml.out +++ b/test/golden/enum.yaml.out @@ -129,8 +129,28 @@ import qualified Web.HttpApiData import Test.Response +data ListPackagesResponse200 + = ListPackagesResponse200A + | ListPackagesResponse200B + | ListPackagesResponse200C + deriving (Eq, Show) + +instance Data.Aeson.ToJSON ListPackagesResponse200 where + toJSON x = case x of + ListPackagesResponse200A -> "A" + ListPackagesResponse200B -> "B" + ListPackagesResponse200C -> "C" + +instance Data.Aeson.FromJSON ListPackagesResponse200 where + parseJSON = Data.Aeson.withText "ListPackagesResponse200" $ \s -> + case s of + "A" -> pure ListPackagesResponse200A + "B" -> pure ListPackagesResponse200B + "C" -> pure ListPackagesResponse200C + _ -> fail "invalid enum value" + data ListPackagesResponse - = ListPackagesResponse200 error: Enum + = ListPackagesResponse200 ListPackagesResponse200 instance ToResponse ListPackagesResponse where toResponse (ListPackagesResponse200 x) = @@ -166,6 +186,8 @@ import Test.Schemas.Package import Test.Response + + data ListPackagesResponse = ListPackagesResponse200 Package diff --git a/test/golden/lists.yaml.out b/test/golden/lists.yaml.out index 605f71d..065f6a9 100644 --- a/test/golden/lists.yaml.out +++ b/test/golden/lists.yaml.out @@ -143,6 +143,8 @@ import Test.Schemas.Packages import Test.Response + + data ListPackagesResponse = ListPackagesResponse200 Packages @@ -180,6 +182,8 @@ import Test.Schemas.Package import Test.Response + + data ListPackages2Response = ListPackages2Response200 [ Package ] @@ -217,6 +221,8 @@ import Test.Schemas.Inline import Test.Response + + data ListPackages3Response = ListPackages3Response200 [ Inline ] diff --git a/test/golden/oneof.yaml.out b/test/golden/oneof.yaml.out index 951f5d2..c80af0b 100644 --- a/test/golden/oneof.yaml.out +++ b/test/golden/oneof.yaml.out @@ -143,6 +143,8 @@ import Test.Schemas.Packages import Test.Response + + data ListPackagesResponse = ListPackagesResponse200 Packages @@ -180,6 +182,8 @@ import Test.Schemas.Inline import Test.Response + + data ListPackages2Response = ListPackages2Response200 Inline @@ -217,6 +221,8 @@ import Test.Schemas.Inline2 import Test.Response + + data ListPackages2Response = ListPackages2Response200 Inline2 diff --git a/test/golden/test1.yaml.out b/test/golden/test1.yaml.out index 33b8a2a..1e084dc 100644 --- a/test/golden/test1.yaml.out +++ b/test/golden/test1.yaml.out @@ -178,6 +178,8 @@ import Test.Schemas.Vehicle import Test.Response + + data CreateUserResponse = CreateUserResponse200 Vehicle @@ -215,6 +217,8 @@ import Test.Schemas.Vehicle import Test.Response + + data GetUserResponse = GetUserResponse200 Vehicle