diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 088b1fba..5efe7948 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -411,7 +411,10 @@ sumToValue letInsert target opts multiCons nullary conName value pairs -- 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 null contentsFieldName + then conString opts conName + else contentsFieldName + content = pairs contentsFieldName' in fromPairsE target $ if nullary then tag else infixApp tag [|(Monoid.<>)|] content ObjectWithSingleField -> @@ -760,11 +763,20 @@ consFromJSON jc tName opts instTys cons = do parseTaggedObject tvMap typFieldName valFieldName 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 null valFieldName + 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 _ _ _ _ diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 7fbacaea..a62a2251 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/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 null contentsFieldName + 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 -> diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index 758f5fc4..58a70987 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -773,6 +773,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 'contentsFieldName' is the empty string, 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 diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index a0900ed3..1fca2ceb 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -1008,12 +1008,14 @@ instance ( IsRecord a isRecord taggedObject opts targs tagFieldName contentsFieldName = 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 null $ Key.toString contentsFieldName + 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