Add option tagAsContentsFieldName to TaggedObject SumEncoding

src/Data/Aeson/TH.hs

@@ -407,11 +407,14 @@ sumToValue letInsert target opts multiCons nullary conName value pairs
         case sumEncoding opts of
           TwoElemArray ->
             array target [conStr target opts conName, value]
-          TaggedObject{tagFieldName, contentsFieldName} ->
+          TaggedObject{tagFieldName, contentsFieldName, tagAsContentsFieldName} ->
             -- TODO: Maybe throw an error in case
             -- tagFieldName overwrites a field in pairs.
             let tag = pairE letInsert target tagFieldName (conStr target opts conName)
-                content = pairs contentsFieldName
+                contentsFieldName' = if tagAsContentsFieldName
+                                     then conString opts conName
+                                     else contentsFieldName
+                content = pairs contentsFieldName'
             in fromPairsE target $
               if nullary then tag else infixApp tag [|(Monoid.<>)|] content
           ObjectWithSingleField ->
@@ -715,8 +718,8 @@ consFromJSON jc tName opts instTys cons = do
 
     mixedMatches tvMap =
         case sumEncoding opts of
-          TaggedObject {tagFieldName, contentsFieldName} ->
-            parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
+          TaggedObject {tagFieldName, contentsFieldName, tagAsContentsFieldName} ->
+            parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName tagAsContentsFieldName
           UntaggedValue -> error "UntaggedValue: Should be handled already"
           ObjectWithSingleField ->
             parseObject $ parseObjectWithSingleField tvMap
@@ -758,13 +761,22 @@ consFromJSON jc tName opts instTys cons = do
                    []
         ]
 
-    parseTaggedObject tvMap typFieldName valFieldName obj = do
+    parseTaggedObject tvMap typFieldName valFieldName tagAsContentsFieldName obj = do
       conKey <- newName "conKeyX"
+      valField <- newName "valField"
       doE [ bindS (varP conKey)
                   (infixApp (varE obj)
                             [|(.:)|]
                             ([|Key.fromString|] `appE` stringE typFieldName))
-          , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
+          , letS [ valD (varP valField)
+                        ( normalB
+                          $ if tagAsContentsFieldName
+                            then varE conKey
+                            else litE $ stringL valFieldName
+                        )
+                        []
+                 ]
+          , noBindS $ parseContents tvMap conKey (Left (valField, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
           ]
 
     parseUntaggedValue tvMap cons' conVal =
@@ -955,19 +967,19 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
              | (field, argTy) <- zip fields argTys
              ]
 
-getValField :: Name -> String -> [MatchQ] -> Q Exp
-getValField obj valFieldName matches = do
+getValField :: Name -> Name -> [MatchQ] -> Q Exp
+getValField obj valField matches = do
   val <- newName "val"
   doE [ bindS (varP val) $ infixApp (varE obj)
                                     [|(.:)|]
                                     ([|Key.fromString|] `appE`
-                                       litE (stringL valFieldName))
+                                       varE valField)
       , noBindS $ caseE (varE val) matches
       ]
 
-matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
-matchCases (Left (valFieldName, obj)) = getValField obj valFieldName
-matchCases (Right valName)            = caseE (varE valName)
+matchCases :: Either (Name, Name) Name -> [MatchQ] -> Q Exp
+matchCases (Left (valField, obj)) = getValField obj valField
+matchCases (Right valName)        = caseE (varE valName)
 
 -- | Generates code to parse the JSON encoding of a single constructor.
 parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
@@ -976,8 +988,8 @@ parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
           -> Name -- ^ Name of the type to which the constructor belongs.
           -> Options -- ^ Encoding options.
           -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
-          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
-                                        --   Right valName
+          -> Either (Name, Name) Name -- ^ Left (valFieldName, objName) or
+                                     --   Right valName
           -> Q Exp
 -- Nullary constructors.
 parseArgs _ _ _ _

src/Data/Aeson/Types/FromJSON.hs

@@ -1209,8 +1209,11 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
       TaggedObject{..} ->
           withObject tname $ \obj -> do
               tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
+              let contentsFieldName' = if tagAsContentsFieldName
+                                       then unpack tag
+                                       else contentsFieldName
               fromMaybe (badTag tag <?> Key tagKey) $
-                  parseFromTaggedObject (tag :* contentsFieldName :* p) obj
+                  parseFromTaggedObject (tag :* contentsFieldName' :* p) obj
         where
           tagKey = Key.fromString tagFieldName
           badTag tag = failWith_ $ \cnames ->

src/Data/Aeson/Types/Internal.hs

@@ -761,8 +761,9 @@ instance Show Options where
 
 -- | Specifies how to encode constructors of a sum datatype.
 data SumEncoding =
-    TaggedObject { tagFieldName      :: String
-                 , contentsFieldName :: String
+    TaggedObject { tagFieldName           :: String
+                 , contentsFieldName      :: String
+                 , tagAsContentsFieldName :: Bool
                  }
     -- ^ A constructor will be encoded to an object with a field
     -- 'tagFieldName' which specifies the constructor tag (modified by
@@ -773,6 +774,9 @@ data SumEncoding =
     -- by the encoded value of that field! If the constructor is not a
     -- record the encoded constructor contents will be stored under
     -- the 'contentsFieldName' field.
+    --
+    -- If 'tagAsContentsFieldName' is True, then the value of
+    -- 'tagFieldName' will be used as the 'contentsFieldName' instead.
   | UntaggedValue
     -- ^ Constructor names won't be encoded. Instead only the contents of the
     -- constructor will be encoded as if the type had a single constructor. JSON
@@ -864,8 +868,9 @@ defaultOptions = Options
 -- @
 defaultTaggedObject :: SumEncoding
 defaultTaggedObject = TaggedObject
-                      { tagFieldName      = "tag"
-                      , contentsFieldName = "contents"
+                      { tagFieldName           = "tag"
+                      , contentsFieldName      = "contents"
+                      , tagAsContentsFieldName = False
                       }
 
 -- | Default 'JSONKeyOptions':

src/Data/Aeson/Types/ToJSON.hs

@@ -961,7 +961,7 @@ nonAllNullarySumToJSON opts targs =
     case sumEncoding opts of
 
       TaggedObject{..}      ->
-        taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName)
+        taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName) tagAsContentsFieldName
 
       ObjectWithSingleField ->
         (unTagged :: Tagged ObjectWithSingleField enc -> enc)
@@ -984,17 +984,17 @@ nonAllNullarySumToJSON opts targs =
 
 class TaggedObject enc arity f where
     taggedObject :: Options -> ToArgs enc arity a
-                 -> Key -> Key
+                 -> Key -> Key -> Bool
                  -> f a -> enc
 
 instance ( TaggedObject enc arity a
          , TaggedObject enc arity b
          ) => TaggedObject enc arity (a :+: b)
   where
-    taggedObject opts targs tagFieldName contentsFieldName (L1 x) =
-        taggedObject opts targs tagFieldName contentsFieldName x
-    taggedObject opts targs tagFieldName contentsFieldName (R1 x) =
-        taggedObject opts targs tagFieldName contentsFieldName x
+    taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName (L1 x) =
+        taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName x
+    taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName (R1 x) =
+        taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName x
     {-# INLINE taggedObject #-}
 
 instance ( IsRecord                      a isRecord
@@ -1005,15 +1005,17 @@ instance ( IsRecord                      a isRecord
          , Constructor c
          ) => TaggedObject enc arity (C1 c a)
   where
-    taggedObject opts targs tagFieldName contentsFieldName =
+    taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName =
       fromPairs . mappend tag . contents
       where
-        tag = tagFieldName `pair`
-          (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
-            :: enc)
+        constructorTagString = constructorTagModifier opts (conName (undefined :: t c a p))
+        tag = tagFieldName `pair` (fromString constructorTagString :: enc)
+        contentsFieldName' = if tagAsContentsFieldName
+          then Key.fromString constructorTagString
+          else contentsFieldName
         contents =
           (unTagged :: Tagged isRecord pairs -> pairs) .
-            taggedObject' opts targs contentsFieldName . unM1
+            taggedObject' opts targs contentsFieldName' . unM1
     {-# INLINE taggedObject #-}
 
 class TaggedObject' enc pairs arity f isRecord where

tests/UnitTests.hs

@@ -280,7 +280,7 @@ showOptions =
         ++ ", allNullaryToStringTag = True"
         ++ ", omitNothingFields = False"
         ++ ", allowOmittedFields = True"
-        ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
+        ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\", tagAsContentsFieldName = False}"
         ++ ", unwrapUnaryRecords = False"
         ++ ", tagSingleConstructors = False"
         ++ ", rejectUnknownFields = False"