diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs index be321930..c2bdb1a9 100644 --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -131,6 +131,7 @@ module Data.Aeson , fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , allNullaryConstructorTagModifier , omitNothingFields , allowOmittedFields , sumEncoding diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 088b1fba..7f9b4c8c 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -335,7 +335,11 @@ consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do -- forgotten. [con] | not (tagSingleConstructors opts) -> [argsToValue letInsert target jc tvMap opts False con] _ | allNullaryToStringTag opts && all isNullary cons -> - [ match (conP conName []) (normalB $ conStr target opts conName) [] + let opts' = opts { constructorTagModifier = + fromMaybe (constructorTagModifier opts) + (allNullaryConstructorTagModifier opts) + } in + [ match (conP conName []) (normalB $ conStr target opts' conName) [] | con <- cons , let conName = constructorName con ] @@ -682,13 +686,17 @@ consFromJSON jc tName opts instTys cons = do else mixedMatches tvMap allNullaryMatches = + let opts' = opts { constructorTagModifier = + fromMaybe (constructorTagModifier opts) + (allNullaryConstructorTagModifier opts) + } in [ do txt <- newName "txtX" match (conP 'String [varP txt]) (guardedB $ [ liftM2 (,) (normalG $ infixApp (varE txt) [|(==)|] - (conTxt opts conName) + (conTxt opts' conName) ) ([|pure|] `appE` conE conName) | con <- cons diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs index 5b556616..c538f402 100644 --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -142,6 +142,7 @@ module Data.Aeson.Types , fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , allNullaryConstructorTagModifier , omitNothingFields , allowOmittedFields , sumEncoding diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 7fbacaea..f99d38cd 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1128,7 +1128,8 @@ parseAllNullarySum tname opts = badTag tag = failWithCTags tname modifier $ \cnames -> "expected one of the tags " ++ show cnames ++ ", but found tag " ++ show tag - modifier = constructorTagModifier opts + modifier = fromMaybe (constructorTagModifier opts) + (allNullaryConstructorTagModifier opts) -- | Fail with an informative error message about a mismatched tag. -- The error message is parameterized by the list of expected tags, diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index 758f5fc4..df6f6c4f 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -56,6 +56,7 @@ module Data.Aeson.Types.Internal fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , allNullaryConstructorTagModifier , omitNothingFields , allowOmittedFields , sumEncoding @@ -714,6 +715,10 @@ data Options = Options -- nullary constructors, will be encoded to just a string with -- the constructor tag. If 'False' the encoding will always -- follow the `sumEncoding`. + , allNullaryConstructorTagModifier :: Maybe (String -> String) + -- ^ If not 'Nothing', specifies the function to be used instead of + -- 'constructorTagModifier' whenever 'allNullaryToStringTag' + -- is in effect. Useful for encoding enums specially. , omitNothingFields :: Bool -- ^ If 'True', record fields with a 'Nothing' value will be -- omitted from the resulting object. If 'False', the resulting @@ -744,12 +749,13 @@ data Options = Options } instance Show Options where - show (Options f c a o q s u t r) = + show (Options f c a ac o q s u t r) = "Options {" ++ intercalate ", " [ "fieldLabelModifier =~ " ++ show (f "exampleField") , "constructorTagModifier =~ " ++ show (c "ExampleConstructor") , "allNullaryToStringTag = " ++ show a + , "allNullaryConstructorTagModifier =~ " ++ show (($ "ExampleConstructor") <$> ac) , "omitNothingFields = " ++ show o , "allowOmittedFields = " ++ show q , "sumEncoding = " ++ show s @@ -843,15 +849,16 @@ data JSONKeyOptions = JSONKeyOptions -- @ defaultOptions :: Options defaultOptions = Options - { fieldLabelModifier = id - , constructorTagModifier = id - , allNullaryToStringTag = True - , omitNothingFields = False - , allowOmittedFields = True - , sumEncoding = defaultTaggedObject - , unwrapUnaryRecords = False - , tagSingleConstructors = False - , rejectUnknownFields = False + { fieldLabelModifier = id + , constructorTagModifier = id + , allNullaryToStringTag = True + , allNullaryConstructorTagModifier = Nothing + , omitNothingFields = False + , allowOmittedFields = True + , sumEncoding = defaultTaggedObject + , unwrapUnaryRecords = False + , tagSingleConstructors = False + , rejectUnknownFields = False } -- | Default 'TaggedObject' 'SumEncoding' options: diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index a0900ed3..bfb1893a 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -938,7 +938,9 @@ instance ( GetConName f where sumToJSON opts targs | allNullaryToStringTag opts = Tagged . fromString - . constructorTagModifier opts . getConName + . fromMaybe (constructorTagModifier opts) + (allNullaryConstructorTagModifier opts) + . getConName | otherwise = Tagged . nonAllNullarySumToJSON opts targs {-# INLINE sumToJSON #-} diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index c9dda427..a6b80719 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -278,6 +278,7 @@ showOptions = ++ "fieldLabelModifier =~ \"exampleField\"" ++ ", constructorTagModifier =~ \"ExampleConstructor\"" ++ ", allNullaryToStringTag = True" + ++ ", allNullaryConstructorTagModifier =~ Nothing" ++ ", omitNothingFields = False" ++ ", allowOmittedFields = True" ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"