loafle/openapi-generator
3
0
Fork 0
forked from loafle/openapi-generator-original
Code Pull Requests Activity

[haskell][haskell-yesod] Fix special char replacements (#16197)

Browse Source 
* [haskell][haskell-yesod] remove fixOperatorChars()

fixOperatorChars() does not change input strings since special
characters have already been replaced in DefaultCodegen.fromModel().

* [haskell][haskell-yesod] do not prefix with quote ("'") when generating removeFieldLabelPrefix table

We switched from the conversion done by fixOperatorChars() to the
conversion done by DefaultCodegen.fromModel() and the latter does not
insert quote characters. So We modify the removeFieldLabelPrefix table
to conform the new mapping.

* [haskell][haskell-yesod] remove forParsing parameter from removeFieldLabelPrefix function

Aeson's fieldLabelModifier always convert Haskell field names to JSON
field names, whether at parse time or not. (Note that stripPrefix and
uncapitalize do not take such parameter)

* [haskell][haskell-yesod] perform replaceSpecialChars after stripping prefix

Because replaceSpecialChars can corrupt prefix if the prefix contains
a replacement string of a specfial character as a substring.

* [haskell][haskell-yesod] regenerate samples
This commit is contained in:
Masahiro Sakai 2023-07-28 10:35:46 +09:00 committed by GitHub
parent d7311cd5cd
commit f6a819686d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 129 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellServantCodegen.java
View File

@ -326,7 +326,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
String c = (String) replacementChar; String c = (String) replacementChar;
Map<String, Object> o = new HashMap<>(); Map<String, Object> o = new HashMap<>();
o.put("char", c); o.put("char", c);
o.put("replacement", "'" + specialCharReplacements.get(c)); o.put("replacement", specialCharReplacements.get(c));
replacements.add(o); replacements.add(o);
} }
additionalProperties.put("specialCharReplacements", replacements); additionalProperties.put("specialCharReplacements", replacements);
@ -636,29 +636,6 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
} }
} }
private String fixOperatorChars(String string) {
StringBuilder sb = new StringBuilder();
String name = string;
//Check if it is a reserved word, in which case the underscore is added when property name is generated.
if (string.startsWith("_")) {
if (reservedWords.contains(string.substring(1))) {
name = string.substring(1);
} else if (reservedWordsMappings.containsValue(string)) {
name = LEADING_UNDERSCORE.matcher(string).replaceFirst("");
}
}
for (char c : name.toCharArray()) {
String cString = String.valueOf(c);
if (specialCharReplacements.containsKey(cString)) {
sb.append("'");
sb.append(specialCharReplacements.get(cString));
} else {
sb.append(c);
}
}
return sb.toString();
}
// Remove characters from a string that do not belong in a model classname // Remove characters from a string that do not belong in a model classname
private String fixModelChars(String string) { private String fixModelChars(String string) {
return string.replace(".", "").replace("-", ""); return string.replace(".", "").replace("-", "");
@ -680,7 +657,7 @@ public class HaskellServantCodegen extends DefaultCodegen implements CodegenConf
// From the model name, compute the prefix for the fields. // From the model name, compute the prefix for the fields.
String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER); String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER);
for (CodegenProperty prop : model.vars) { for (CodegenProperty prop : model.vars) {
prop.name = toVarName(prefix + camelize(fixOperatorChars(prop.name))); prop.name = toVarName(prefix + camelize(prop.name));
} }
// Create newtypes for things with non-object types // Create newtypes for things with non-object types

27
modules/openapi-generator/src/main/java/org/openapitools/codegen/languages/HaskellYesodServerCodegen.java
View File

@ -286,7 +286,7 @@ public class HaskellYesodServerCodegen extends DefaultCodegen implements Codegen
String c = (String) replacementChar; String c = (String) replacementChar;
Map<String, Object> o = new HashMap<>(); Map<String, Object> o = new HashMap<>();
o.put("char", c); o.put("char", c);
o.put("replacement", "'" + specialCharReplacements.get(c)); o.put("replacement", specialCharReplacements.get(c));
replacements.add(o); replacements.add(o);
} }
additionalProperties.put("specialCharReplacements", replacements); additionalProperties.put("specialCharReplacements", replacements);
@ -530,29 +530,6 @@ public class HaskellYesodServerCodegen extends DefaultCodegen implements Codegen
} }
} }
private String fixOperatorChars(String string) {
StringBuilder sb = new StringBuilder();
String name = string;
//Check if it is a reserved word, in which case the underscore is added when property name is generated.
if (string.startsWith("_")) {
if (reservedWords.contains(string.substring(1))) {
name = string.substring(1);
} else if (reservedWordsMappings.containsValue(string)) {
name = LEADING_UNDERSCORE.matcher(string).replaceFirst("");
}
}
for (char c : name.toCharArray()) {
String cString = String.valueOf(c);
if (specialCharReplacements.containsKey(cString)) {
sb.append("'");
sb.append(specialCharReplacements.get(cString));
} else {
sb.append(c);
}
}
return sb.toString();
}
// Remove characters from a string that do not belong in a model classname // Remove characters from a string that do not belong in a model classname
private String fixModelChars(String string) { private String fixModelChars(String string) {
return string.replace(".", "").replace("-", ""); return string.replace(".", "").replace("-", "");
@ -574,7 +551,7 @@ public class HaskellYesodServerCodegen extends DefaultCodegen implements Codegen
// From the model name, compute the prefix for the fields. // From the model name, compute the prefix for the fields.
String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER); String prefix = camelize(model.classname, LOWERCASE_FIRST_LETTER);
for (CodegenProperty prop : model.vars) { for (CodegenProperty prop : model.vars) {
prop.name = toVarName(prefix + camelize(fixOperatorChars(prop.name))); prop.name = toVarName(prefix + camelize(prop.name));
} }
// Create newtypes for things with non-object types // Create newtypes for things with non-object types

22
modules/openapi-generator/src/main/resources/haskell-servant/Types.mustache vendored
View File

@ -42,14 +42,14 @@ import Data.Function ((&))
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON {{classname}} where instance FromJSON {{classname}} where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}") parseJSON = genericParseJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
instance ToJSON {{classname}} where instance ToJSON {{classname}} where
toJSON = genericToJSON (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}") toJSON = genericToJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
{{#generateToSchema}} {{#generateToSchema}}
instance ToSchema {{classname}} where instance ToSchema {{classname}} where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}" $ removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}"
{{/generateToSchema}} {{/generateToSchema}}
{{/parent}} {{/parent}}
@ -70,15 +70,11 @@ uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing. -- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
-- The @forParsing@ parameter is to distinguish between the cases in which we're using this removeFieldLabelPrefix :: String -> Options
-- to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want removeFieldLabelPrefix prefix =
-- to replace special characters with their quoted equivalents (because we cannot have special
-- chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{ omitNothingFields = True { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars , fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
} }
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
@ -86,8 +82,4 @@ removeFieldLabelPrefix forParsing prefix =
[ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}} [ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}}
, {{/-last}}{{/specialCharReplacements}} , {{/-last}}{{/specialCharReplacements}}
] ]
mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack
replacer =
if forParsing
then flip T.replace
else T.replace

20
modules/openapi-generator/src/main/resources/haskell-yesod/src/API/Types.mustache vendored
View File

@ -36,9 +36,9 @@ import Data.Function ((&))
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON {{classname}} where instance FromJSON {{classname}} where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "{{vendorExtensions.x-prefix}}") parseJSON = genericParseJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
instance ToJSON {{classname}} where instance ToJSON {{classname}} where
toJSON = genericToJSON (removeFieldLabelPrefix False "{{vendorExtensions.x-prefix}}") toJSON = genericToJSON (removeFieldLabelPrefix "{{vendorExtensions.x-prefix}}")
{{/parent}} {{/parent}}
{{#parent}} {{#parent}}
@ -58,15 +58,11 @@ uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing. -- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
-- The @forParsing@ parameter is to distinguish between the cases in which we're using this removeFieldLabelPrefix :: String -> Options
-- to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want removeFieldLabelPrefix prefix =
-- to replace special characters with their quoted equivalents (because we cannot have special
-- chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{ omitNothingFields = True { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars , fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
} }
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
@ -74,8 +70,4 @@ removeFieldLabelPrefix forParsing prefix =
[ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}} [ {{#specialCharReplacements}}("{{&char}}", "{{&replacement}}"){{^-last}}
, {{/-last}}{{/specialCharReplacements}} , {{/-last}}{{/specialCharReplacements}}
] ]
mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack
replacer =
if forParsing
then flip T.replace
else T.replace

126
samples/server/petstore/haskell-servant/lib/OpenAPIPetstore/Types.hs
View File

@ -38,13 +38,13 @@ data ApiResponse = ApiResponse
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON ApiResponse where instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse") parseJSON = genericParseJSON (removeFieldLabelPrefix "apiResponse")
instance ToJSON ApiResponse where instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse") toJSON = genericToJSON (removeFieldLabelPrefix "apiResponse")
instance ToSchema ApiResponse where instance ToSchema ApiResponse where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "apiResponse" $ removeFieldLabelPrefix "apiResponse"
-- | A category for a pet -- | A category for a pet
@ -54,13 +54,13 @@ data Category = Category
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON Category where instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "category") parseJSON = genericParseJSON (removeFieldLabelPrefix "category")
instance ToJSON Category where instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix False "category") toJSON = genericToJSON (removeFieldLabelPrefix "category")
instance ToSchema Category where instance ToSchema Category where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "category" $ removeFieldLabelPrefix "category"
-- | An order for a pets from the pet store -- | An order for a pets from the pet store
@ -74,13 +74,13 @@ data Order = Order
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON Order where instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "order") parseJSON = genericParseJSON (removeFieldLabelPrefix "order")
instance ToJSON Order where instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix False "order") toJSON = genericToJSON (removeFieldLabelPrefix "order")
instance ToSchema Order where instance ToSchema Order where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "order" $ removeFieldLabelPrefix "order"
-- | A pet for sale in the pet store -- | A pet for sale in the pet store
@ -94,13 +94,13 @@ data Pet = Pet
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON Pet where instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet") parseJSON = genericParseJSON (removeFieldLabelPrefix "pet")
instance ToJSON Pet where instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix False "pet") toJSON = genericToJSON (removeFieldLabelPrefix "pet")
instance ToSchema Pet where instance ToSchema Pet where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "pet" $ removeFieldLabelPrefix "pet"
-- | A tag for a pet -- | A tag for a pet
@ -110,13 +110,13 @@ data Tag = Tag
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON Tag where instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag") parseJSON = genericParseJSON (removeFieldLabelPrefix "tag")
instance ToJSON Tag where instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix False "tag") toJSON = genericToJSON (removeFieldLabelPrefix "tag")
instance ToSchema Tag where instance ToSchema Tag where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "tag" $ removeFieldLabelPrefix "tag"
-- | A User who is purchasing from the pet store -- | A User who is purchasing from the pet store
@ -132,13 +132,13 @@ data User = User
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance FromJSON User where instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "user") parseJSON = genericParseJSON (removeFieldLabelPrefix "user")
instance ToJSON User where instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix False "user") toJSON = genericToJSON (removeFieldLabelPrefix "user")
instance ToSchema User where instance ToSchema User where
declareNamedSchema = Swagger.genericDeclareNamedSchema declareNamedSchema = Swagger.genericDeclareNamedSchema
$ Swagger.fromAesonOptions $ Swagger.fromAesonOptions
$ removeFieldLabelPrefix False "user" $ removeFieldLabelPrefix "user"
uncapitalize :: String -> String uncapitalize :: String -> String
@ -147,59 +147,51 @@ uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing. -- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
-- The @forParsing@ parameter is to distinguish between the cases in which we're using this removeFieldLabelPrefix :: String -> Options
-- to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want removeFieldLabelPrefix prefix =
-- to replace special characters with their quoted equivalents (because we cannot have special
-- chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{ omitNothingFields = True { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars , fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
} }
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars = specialChars =
[ ("$", "'Dollar") [ ("$", "Dollar")
, ("^", "'Caret") , ("^", "Caret")
, ("|", "'Pipe") , ("|", "Pipe")
, ("=", "'Equal") , ("=", "Equal")
, ("*", "'Star") , ("*", "Star")
, ("-", "'Dash") , ("-", "Dash")
, ("&", "'Ampersand") , ("&", "Ampersand")
, ("%", "'Percent") , ("%", "Percent")
, ("#", "'Hash") , ("#", "Hash")
, ("@", "'At") , ("@", "At")
, ("!", "'Exclamation") , ("!", "Exclamation")
, ("+", "'Plus") , ("+", "Plus")
, (":", "'Colon") , (":", "Colon")
, (";", "'Semicolon") , (";", "Semicolon")
, (">", "'GreaterThan") , (">", "GreaterThan")
, ("<", "'LessThan") , ("<", "LessThan")
, (".", "'Period") , (".", "Period")
, ("_", "'Underscore") , ("_", "Underscore")
, ("?", "'Question_Mark") , ("?", "Question_Mark")
, (",", "'Comma") , (",", "Comma")
, ("'", "'Quote") , ("'", "Quote")
, ("/", "'Slash") , ("/", "Slash")
, ("(", "'Left_Parenthesis") , ("(", "Left_Parenthesis")
, (")", "'Right_Parenthesis") , (")", "Right_Parenthesis")
, ("{", "'Left_Curly_Bracket") , ("{", "Left_Curly_Bracket")
, ("}", "'Right_Curly_Bracket") , ("}", "Right_Curly_Bracket")
, ("[", "'Left_Square_Bracket") , ("[", "Left_Square_Bracket")
, ("]", "'Right_Square_Bracket") , ("]", "Right_Square_Bracket")
, ("~", "'Tilde") , ("~", "Tilde")
, ("`", "'Backtick") , ("`", "Backtick")
, ("<=", "'Less_Than_Or_Equal_To") , ("<=", "Less_Than_Or_Equal_To")
, (">=", "'Greater_Than_Or_Equal_To") , (">=", "Greater_Than_Or_Equal_To")
, ("!=", "'Not_Equal") , ("!=", "Not_Equal")
, ("<>", "'Not_Equal") , ("<>", "Not_Equal")
, ("~=", "'Tilde_Equal") , ("~=", "Tilde_Equal")
, ("\\", "'Back_Slash") , ("\\", "Back_Slash")
, ("\"", "'Double_Quote") , ("\"", "Double_Quote")
] ]
mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack
replacer =
if forParsing
then flip T.replace
else T.replace

114
samples/server/petstore/haskell-yesod/src/OpenAPIPetstore/Types.hs
View File

@ -32,9 +32,9 @@ data ApiResponse = ApiResponse
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON ApiResponse where instance FromJSON ApiResponse where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "apiResponse") parseJSON = genericParseJSON (removeFieldLabelPrefix "apiResponse")
instance ToJSON ApiResponse where instance ToJSON ApiResponse where
toJSON = genericToJSON (removeFieldLabelPrefix False "apiResponse") toJSON = genericToJSON (removeFieldLabelPrefix "apiResponse")
-- | A category for a pet -- | A category for a pet
@ -44,9 +44,9 @@ data Category = Category
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON Category where instance FromJSON Category where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "category") parseJSON = genericParseJSON (removeFieldLabelPrefix "category")
instance ToJSON Category where instance ToJSON Category where
toJSON = genericToJSON (removeFieldLabelPrefix False "category") toJSON = genericToJSON (removeFieldLabelPrefix "category")
-- | An order for a pets from the pet store -- | An order for a pets from the pet store
@ -60,9 +60,9 @@ data Order = Order
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON Order where instance FromJSON Order where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "order") parseJSON = genericParseJSON (removeFieldLabelPrefix "order")
instance ToJSON Order where instance ToJSON Order where
toJSON = genericToJSON (removeFieldLabelPrefix False "order") toJSON = genericToJSON (removeFieldLabelPrefix "order")
-- | A pet for sale in the pet store -- | A pet for sale in the pet store
@ -76,9 +76,9 @@ data Pet = Pet
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON Pet where instance FromJSON Pet where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "pet") parseJSON = genericParseJSON (removeFieldLabelPrefix "pet")
instance ToJSON Pet where instance ToJSON Pet where
toJSON = genericToJSON (removeFieldLabelPrefix False "pet") toJSON = genericToJSON (removeFieldLabelPrefix "pet")
-- | A tag for a pet -- | A tag for a pet
@ -88,9 +88,9 @@ data Tag = Tag
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON Tag where instance FromJSON Tag where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "tag") parseJSON = genericParseJSON (removeFieldLabelPrefix "tag")
instance ToJSON Tag where instance ToJSON Tag where
toJSON = genericToJSON (removeFieldLabelPrefix False "tag") toJSON = genericToJSON (removeFieldLabelPrefix "tag")
-- | A User who is purchasing from the pet store -- | A User who is purchasing from the pet store
@ -106,9 +106,9 @@ data User = User
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance FromJSON User where instance FromJSON User where
parseJSON = genericParseJSON (removeFieldLabelPrefix True "user") parseJSON = genericParseJSON (removeFieldLabelPrefix "user")
instance ToJSON User where instance ToJSON User where
toJSON = genericToJSON (removeFieldLabelPrefix False "user") toJSON = genericToJSON (removeFieldLabelPrefix "user")
uncapitalize :: String -> String uncapitalize :: String -> String
@ -117,59 +117,51 @@ uncapitalize [] = []
-- | Remove a field label prefix during JSON parsing. -- | Remove a field label prefix during JSON parsing.
-- Also perform any replacements for special characters. -- Also perform any replacements for special characters.
-- The @forParsing@ parameter is to distinguish between the cases in which we're using this removeFieldLabelPrefix :: String -> Options
-- to power a @FromJSON@ or a @ToJSON@ instance. In the first case we're parsing, and we want removeFieldLabelPrefix prefix =
-- to replace special characters with their quoted equivalents (because we cannot have special
-- chars in identifier names), while we want to do vice versa when sending data instead.
removeFieldLabelPrefix :: Bool -> String -> Options
removeFieldLabelPrefix forParsing prefix =
defaultOptions defaultOptions
{ omitNothingFields = True { omitNothingFields = True
, fieldLabelModifier = uncapitalize . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix . replaceSpecialChars , fieldLabelModifier = uncapitalize . replaceSpecialChars . fromMaybe (error ("did not find prefix " ++ prefix)) . stripPrefix prefix
} }
where where
replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars) replaceSpecialChars field = foldl (&) field (map mkCharReplacement specialChars)
specialChars = specialChars =
[ ("$", "'Dollar") [ ("$", "Dollar")
, ("^", "'Caret") , ("^", "Caret")
, ("|", "'Pipe") , ("|", "Pipe")
, ("=", "'Equal") , ("=", "Equal")
, ("*", "'Star") , ("*", "Star")
, ("-", "'Dash") , ("-", "Dash")
, ("&", "'Ampersand") , ("&", "Ampersand")
, ("%", "'Percent") , ("%", "Percent")
, ("#", "'Hash") , ("#", "Hash")
, ("@", "'At") , ("@", "At")
, ("!", "'Exclamation") , ("!", "Exclamation")
, ("+", "'Plus") , ("+", "Plus")
, (":", "'Colon") , (":", "Colon")
, (";", "'Semicolon") , (";", "Semicolon")
, (">", "'GreaterThan") , (">", "GreaterThan")
, ("<", "'LessThan") , ("<", "LessThan")
, (".", "'Period") , (".", "Period")
, ("_", "'Underscore") , ("_", "Underscore")
, ("?", "'Question_Mark") , ("?", "Question_Mark")
, (",", "'Comma") , (",", "Comma")
, ("'", "'Quote") , ("'", "Quote")
, ("/", "'Slash") , ("/", "Slash")
, ("(", "'Left_Parenthesis") , ("(", "Left_Parenthesis")
, (")", "'Right_Parenthesis") , (")", "Right_Parenthesis")
, ("{", "'Left_Curly_Bracket") , ("{", "Left_Curly_Bracket")
, ("}", "'Right_Curly_Bracket") , ("}", "Right_Curly_Bracket")
, ("[", "'Left_Square_Bracket") , ("[", "Left_Square_Bracket")
, ("]", "'Right_Square_Bracket") , ("]", "Right_Square_Bracket")
, ("~", "'Tilde") , ("~", "Tilde")
, ("`", "'Backtick") , ("`", "Backtick")
, ("<=", "'Less_Than_Or_Equal_To") , ("<=", "Less_Than_Or_Equal_To")
, (">=", "'Greater_Than_Or_Equal_To") , (">=", "Greater_Than_Or_Equal_To")
, ("!=", "'Not_Equal") , ("!=", "Not_Equal")
, ("<>", "'Not_Equal") , ("<>", "Not_Equal")
, ("~=", "'Tilde_Equal") , ("~=", "Tilde_Equal")
, ("\\", "'Back_Slash") , ("\\", "Back_Slash")
, ("\"", "'Double_Quote") , ("\"", "Double_Quote")
] ]
mkCharReplacement (replaceStr, searchStr) = T.unpack . replacer (T.pack searchStr) (T.pack replaceStr) . T.pack mkCharReplacement (replaceStr, searchStr) = T.unpack . T.replace (T.pack searchStr) (T.pack replaceStr) . T.pack
replacer =
if forParsing
then flip T.replace
else T.replace