[haskell-servant][haskell-yesod] Use table-based conversion for field name conversion (#16232)

* [haskell-servant][haskell-yesod] use table-based conversion for field name conversion

Current fieldLabelModifier implementation always produces uncapitalize
name, but it is inappropriate if the original JSON field name begins
with a capital letter.

* [haskell-servant][haskell-yesod] regenerate samples
This commit is contained in:
Masahiro Sakai 2023-08-03 14:29:33 +09:00 committed by GitHub
parent 81c398e530
commit 45d8027bb4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 229 additions and 185 deletions

View File

@ -658,6 +658,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER);
for (CodegenProperty prop : model.vars) {
prop.name = toVarName(prefix + camelize(prop.name));
prop.vendorExtensions.put("x-base-name-string-literal", "\"" + escapeText(prop.getBaseName()) + "\"");
}
// Create newtypes for things with non-object types
@ -668,8 +669,6 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
model.vendorExtensions.put("x-custom-newtype", newtype);
}
// Provide the prefix as a vendor extension, so that it can be used in the ToJSON and FromJSON instances.
model.vendorExtensions.put("x-prefix", prefix);
model.vendorExtensions.put("x-data", dataOrNewtype);
return model;

View File

@ -552,6 +552,7 @@ public class HaskellYesodServerCodegen extends DefaultCodegen implements Codegen
String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER);
for (CodegenProperty prop : model.vars) {
prop.name = toVarName(prefix + camelize(prop.name));
prop.vendorExtensions.put("x-base-name-string-literal", "\"" + escapeText(prop.getBaseName()) + "\"");
}
// Create newtypes for things with non-object types
@ -562,8 +563,6 @@ public class HaskellYesodServerCodegen extends DefaultCodegen implements Codegen
model.vendorExtensions.put("x-custom-newtype", newtype);
}
// Provide the prefix as a vendor extension, so that it can be used in the ToJSON and FromJSON instances.
model.vendorExtensions.put("x-prefix", prefix);
model.vendorExtensions.put("x-data", dataOrNewtype);
return model;

View File

@ -13,7 +13,7 @@ module {{title}}.Types (
import Data.Data (Data)
import Data.UUID (UUID)
import Data.List (stripPrefix)
import Data.List (lookup)
import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions)
@ -26,7 +26,6 @@ import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Data.Function ((&))
{{#imports}}import {{import}}
{{/imports}}
@ -42,16 +41,28 @@ import Data.Function ((&))
} deriving (Show, Eq, Generic, Data)
instance FromJSON {{classname}} where
parseJSON = genericParseJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
parseJSON = genericParseJSON options{{classname}}
instance ToJSON {{classname}} where
toJSON = genericToJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
toJSON = genericToJSON options{{classname}}
{{#generateToSchema}}
instance ToSchema {{classname}} where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}"
$ options{{classname}}
{{/generateToSchema}}
options{{classname}} :: Options
options{{classname}} =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ {{#vars}}("{{& name}}", {{& vendorExtensions.x-base-name-string-literal}}){{^-last}}
, {{/-last}}{{/vars}}
]
{{/parent}}
{{#parent}}
newtype {{classname}} = {{classname}} { un{{classname}} :: {{parent}} }
@ -63,23 +74,3 @@ newtype {{classname}} = {{classname}} {{vendorExtensions.x-custom-newtype}} deri
{{/vendorExtensions.x-custom-newtype}}
{{/model}}
{{/models}}
uncapitalize :: String -> String
uncapitalize (first:rest) = Char.toLower first : rest
uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters.
removeFieldLabelPrefix :: String -> Options
removeFieldLabelPrefix prefix =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
}
where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars =
[ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}}
, {{/-last}}{{/specialCharReplacements}}
]
mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack

View File

@ -13,6 +13,7 @@ module {{apiModuleName}}.Types (
import ClassyPrelude.Yesod
import Data.Foldable (foldl)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions)
@ -20,7 +21,6 @@ import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Data.Function ((&))
{{#imports}}import {{import}}
{{/imports}}
@ -36,9 +36,21 @@ import Data.Function ((&))
} deriving (Show, Eq, Generic)
instance FromJSON {{classname}} where
parseJSON = genericParseJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
parseJSON = genericParseJSON options{{classname}}
instance ToJSON {{classname}} where
toJSON = genericToJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
toJSON = genericToJSON options{{classname}}
options{{classname}} :: Options
options{{classname}} =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ {{#vars}}("{{& name}}", {{& vendorExtensions.x-base-name-string-literal}}){{^-last}}
, {{/-last}}{{/vars}}
]
{{/parent}}
{{#parent}}
@ -51,23 +63,3 @@ newtype {{classname}} = {{classname}} {{vendorExtensions.x-custom-newtype}} deri
{{/vendorExtensions.x-custom-newtype}}
{{/model}}
{{/models}}
uncapitalize :: String -> String
uncapitalize (c : cs) = Char.toLower c : cs
uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters.
removeFieldLabelPrefix :: String -> Options
removeFieldLabelPrefix prefix =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
}
where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars =
[ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}}
, {{/-last}}{{/specialCharReplacements}}
]
mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack

View File

@ -14,7 +14,7 @@ module OpenAPIPetstore.Types (
import Data.Data (Data)
import Data.UUID (UUID)
import Data.List (stripPrefix)
import Data.List (lookup)
import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions)
@ -27,7 +27,6 @@ import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Data.Function ((&))
-- | Describes the result of uploading an image resource
@ -38,13 +37,26 @@ data ApiResponse = ApiResponse
} deriving (Show, Eq, Generic, Data)
instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix "apiResponse")
parseJSON = genericParseJSON optionsApiResponse
instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix "apiResponse")
toJSON = genericToJSON optionsApiResponse
instance ToSchema ApiResponse where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "apiResponse"
$ optionsApiResponse
optionsApiResponse :: Options
optionsApiResponse =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ ("apiResponseCode", "code")
, ("apiResponseType", "type")
, ("apiResponseMessage", "message")
]
-- | A category for a pet
@ -54,13 +66,25 @@ data Category = Category
} deriving (Show, Eq, Generic, Data)
instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix "category")
parseJSON = genericParseJSON optionsCategory
instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix "category")
toJSON = genericToJSON optionsCategory
instance ToSchema Category where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "category"
$ optionsCategory
optionsCategory :: Options
optionsCategory =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ ("categoryId", "id")
, ("categoryName", "name")
]
-- | An order for a pets from the pet store
@ -74,13 +98,29 @@ data Order = Order
} deriving (Show, Eq, Generic, Data)
instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix "order")
parseJSON = genericParseJSON optionsOrder
instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix "order")
toJSON = genericToJSON optionsOrder
instance ToSchema Order where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "order"
$ optionsOrder
optionsOrder :: Options
optionsOrder =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ ("orderId", "id")
, ("orderPetId", "petId")
, ("orderQuantity", "quantity")
, ("orderShipDate", "shipDate")
, ("orderStatus", "status")
, ("orderComplete", "complete")
]
-- | A pet for sale in the pet store
@ -94,13 +134,29 @@ data Pet = Pet
} deriving (Show, Eq, Generic, Data)
instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix "pet")
parseJSON = genericParseJSON optionsPet
instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix "pet")
toJSON = genericToJSON optionsPet
instance ToSchema Pet where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "pet"
$ optionsPet
optionsPet :: Options
optionsPet =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ ("petId", "id")
, ("petCategory", "category")
, ("petName", "name")
, ("petPhotoUrls", "photoUrls")
, ("petTags", "tags")
, ("petStatus", "status")
]
-- | A tag for a pet
@ -110,13 +166,25 @@ data Tag = Tag
} deriving (Show, Eq, Generic, Data)
instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix "tag")
parseJSON = genericParseJSON optionsTag
instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix "tag")
toJSON = genericToJSON optionsTag
instance ToSchema Tag where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "tag"
$ optionsTag
optionsTag :: Options
optionsTag =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
table =
[ ("tagId", "id")
, ("tagName", "name")
]
-- | A User who is purchasing from the pet store
@ -132,66 +200,29 @@ data User = User
} deriving (Show, Eq, Generic, Data)
instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix "user")
parseJSON = genericParseJSON optionsUser
instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix "user")
toJSON = genericToJSON optionsUser
instance ToSchema User where
declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions
$ removeFieldLabelPrefix "user"
$ optionsUser
uncapitalize :: String -> String
uncapitalize (first:rest) = Char.toLower first : rest
uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters.
removeFieldLabelPrefix :: String -> Options
removeFieldLabelPrefix prefix =
optionsUser :: Options
optionsUser =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ lookup s table
}
where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars =
[ ("$", "Dollar")
, ("^", "Caret")
, ("|", "Pipe")
, ("=", "Equal")
, ("*", "Star")
, ("-", "Dash")
, ("&", "Ampersand")
, ("%", "Percent")
, ("#", "Hash")
, ("@", "At")
, ("!", "Exclamation")
, ("+", "Plus")
, (":", "Colon")
, (";", "Semicolon")
, (">", "GreaterThan")
, ("<", "LessThan")
, (".", "Period")
, ("_", "Underscore")
, ("?", "Question_Mark")
, (",", "Comma")
, ("'", "Quote")
, ("/", "Slash")
, ("(", "Left_Parenthesis")
, (")", "Right_Parenthesis")
, ("{", "Left_Curly_Bracket")
, ("}", "Right_Curly_Bracket")
, ("[", "Left_Square_Bracket")
, ("]", "Right_Square_Bracket")
, ("~", "Tilde")
, ("`", "Backtick")
, ("<=", "Less_Than_Or_Equal_To")
, (">=", "Greater_Than_Or_Equal_To")
, ("!=", "Not_Equal")
, ("<>", "Not_Equal")
, ("~=", "Tilde_Equal")
, ("\\", "Back_Slash")
, ("\"", "Double_Quote")
table =
[ ("userId", "id")
, ("userUsername", "username")
, ("userFirstName", "firstName")
, ("userLastName", "lastName")
, ("userEmail", "email")
, ("userPassword", "password")
, ("userPhone", "phone")
, ("userUserStatus", "userStatus")
]
mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack

View File

@ -14,6 +14,7 @@ module OpenAPIPetstore.Types (
import ClassyPrelude.Yesod
import Data.Foldable (foldl)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.Aeson (Value, FromJSON(..), ToJSON(..), genericToJSON, genericParseJSON)
import Data.Aeson.Types (Options(..), defaultOptions)
@ -21,7 +22,6 @@ import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Data.Function ((&))
-- | Describes the result of uploading an image resource
@ -32,9 +32,22 @@ data ApiResponse = ApiResponse
} deriving (Show, Eq, Generic)
instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix "apiResponse")
parseJSON = genericParseJSON optionsApiResponse
instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix "apiResponse")
toJSON = genericToJSON optionsApiResponse
optionsApiResponse :: Options
optionsApiResponse =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ ("apiResponseCode", "code")
, ("apiResponseType", "type")
, ("apiResponseMessage", "message")
]
-- | A category for a pet
@ -44,9 +57,21 @@ data Category = Category
} deriving (Show, Eq, Generic)
instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix "category")
parseJSON = genericParseJSON optionsCategory
instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix "category")
toJSON = genericToJSON optionsCategory
optionsCategory :: Options
optionsCategory =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ ("categoryId", "id")
, ("categoryName", "name")
]
-- | An order for a pets from the pet store
@ -60,9 +85,25 @@ data Order = Order
} deriving (Show, Eq, Generic)
instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix "order")
parseJSON = genericParseJSON optionsOrder
instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix "order")
toJSON = genericToJSON optionsOrder
optionsOrder :: Options
optionsOrder =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ ("orderId", "id")
, ("orderPetId", "petId")
, ("orderQuantity", "quantity")
, ("orderShipDate", "shipDate")
, ("orderStatus", "status")
, ("orderComplete", "complete")
]
-- | A pet for sale in the pet store
@ -76,9 +117,25 @@ data Pet = Pet
} deriving (Show, Eq, Generic)
instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix "pet")
parseJSON = genericParseJSON optionsPet
instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix "pet")
toJSON = genericToJSON optionsPet
optionsPet :: Options
optionsPet =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ ("petId", "id")
, ("petCategory", "category")
, ("petName", "name")
, ("petPhotoUrls", "photoUrls")
, ("petTags", "tags")
, ("petStatus", "status")
]
-- | A tag for a pet
@ -88,9 +145,21 @@ data Tag = Tag
} deriving (Show, Eq, Generic)
instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix "tag")
parseJSON = genericParseJSON optionsTag
instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix "tag")
toJSON = genericToJSON optionsTag
optionsTag :: Options
optionsTag =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
table =
[ ("tagId", "id")
, ("tagName", "name")
]
-- | A User who is purchasing from the pet store
@ -106,62 +175,25 @@ data User = User
} deriving (Show, Eq, Generic)
instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix "user")
parseJSON = genericParseJSON optionsUser
instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix "user")
toJSON = genericToJSON optionsUser
uncapitalize :: String -> String
uncapitalize (c : cs) = Char.toLower c : cs
uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters.
removeFieldLabelPrefix :: String -> Options
removeFieldLabelPrefix prefix =
optionsUser :: Options
optionsUser =
defaultOptions
{ omitNothingFields = True
, fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
, fieldLabelModifier = \s -> fromMaybe ("did not find JSON field name for " ++ show s) $ List.lookup s table
}
where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars =
[ ("$", "Dollar")
, ("^", "Caret")
, ("|", "Pipe")
, ("=", "Equal")
, ("*", "Star")
, ("-", "Dash")
, ("&", "Ampersand")
, ("%", "Percent")
, ("#", "Hash")
, ("@", "At")
, ("!", "Exclamation")
, ("+", "Plus")
, (":", "Colon")
, (";", "Semicolon")
, (">", "GreaterThan")
, ("<", "LessThan")
, (".", "Period")
, ("_", "Underscore")
, ("?", "Question_Mark")
, (",", "Comma")
, ("'", "Quote")
, ("/", "Slash")
, ("(", "Left_Parenthesis")
, (")", "Right_Parenthesis")
, ("{", "Left_Curly_Bracket")
, ("}", "Right_Curly_Bracket")
, ("[", "Left_Square_Bracket")
, ("]", "Right_Square_Bracket")
, ("~", "Tilde")
, ("`", "Backtick")
, ("<=", "Less_Than_Or_Equal_To")
, (">=", "Greater_Than_Or_Equal_To")
, ("!=", "Not_Equal")
, ("<>", "Not_Equal")
, ("~=", "Tilde_Equal")
, ("\\", "Back_Slash")
, ("\"", "Double_Quote")
table =
[ ("userId", "id")
, ("userUsername", "username")
, ("userFirstName", "firstName")
, ("userLastName", "lastName")
, ("userEmail", "email")
, ("userPassword", "password")
, ("userPhone", "phone")
, ("userUserStatus", "userStatus")
]
mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack