allNullaryConstructorTagModifier

Author: wi11dey

src/Data/Aeson.hs

@@ -131,6 +131,7 @@ module Data.Aeson
     , fieldLabelModifier
     , constructorTagModifier
     , allNullaryToStringTag
+    , allNullaryConstructorTagModifier
     , omitNothingFields
     , allowOmittedFields
     , sumEncoding

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

src/Data/Aeson/Types.hs

@@ -142,6 +142,7 @@ module Data.Aeson.Types
     , fieldLabelModifier
     , constructorTagModifier
     , allNullaryToStringTag
+    , allNullaryConstructorTagModifier
     , omitNothingFields
     , allowOmittedFields
     , sumEncoding

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,

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:

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

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\"}"