From 55fe395c5878fc992488dea0350a83a848c731bb Mon Sep 17 00:00:00 2001 From: Will Dey Date: Thu, 31 Jul 2025 23:48:02 +0100 Subject: [PATCH 1/2] Add support for TaggedObject.tagAsContentsFieldName --- src/Data/Aeson/TH.hs | 40 +++++++++++++++++++++----------- src/Data/Aeson/Types/FromJSON.hs | 5 +++- src/Data/Aeson/Types/Internal.hs | 13 +++++++---- src/Data/Aeson/Types/ToJSON.hs | 24 ++++++++++--------- tests/UnitTests.hs | 2 +- 5 files changed, 53 insertions(+), 31 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 088b1fbae..a06661b2b 100644 --- a/src/Data/Aeson/TH.hs +++ b/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 _ _ _ _ diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 7fbacaeaa..f27dceb73 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 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 -> diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index 758f5fc4b..fe068fe20 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/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': diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index a0900ed32..8ce7c2405 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/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 diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index c9dda427e..46cf9b7b4 100644 --- a/tests/UnitTests.hs +++ b/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" From fd0fea81684a585c70d35869aa320e9bd924eb04 Mon Sep 17 00:00:00 2001 From: Will Dey Date: Tue, 26 Aug 2025 20:02:21 +0100 Subject: [PATCH 2/2] empty contentsFieldName means use tag value as content field name --- src/Data/Aeson/TH.hs | 12 ++++++------ src/Data/Aeson/Types/FromJSON.hs | 2 +- src/Data/Aeson/Types/Internal.hs | 12 +++++------- src/Data/Aeson/Types/ToJSON.hs | 20 ++++++++++---------- tests/UnitTests.hs | 2 +- 5 files changed, 23 insertions(+), 25 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index a06661b2b..5efe79483 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -407,11 +407,11 @@ sumToValue letInsert target opts multiCons nullary conName value pairs case sumEncoding opts of TwoElemArray -> array target [conStr target opts conName, value] - TaggedObject{tagFieldName, contentsFieldName, tagAsContentsFieldName} -> + TaggedObject{tagFieldName, contentsFieldName} -> -- TODO: Maybe throw an error in case -- tagFieldName overwrites a field in pairs. let tag = pairE letInsert target tagFieldName (conStr target opts conName) - contentsFieldName' = if tagAsContentsFieldName + contentsFieldName' = if null contentsFieldName then conString opts conName else contentsFieldName content = pairs contentsFieldName' @@ -718,8 +718,8 @@ consFromJSON jc tName opts instTys cons = do mixedMatches tvMap = case sumEncoding opts of - TaggedObject {tagFieldName, contentsFieldName, tagAsContentsFieldName} -> - parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName tagAsContentsFieldName + TaggedObject {tagFieldName, contentsFieldName} -> + parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName UntaggedValue -> error "UntaggedValue: Should be handled already" ObjectWithSingleField -> parseObject $ parseObjectWithSingleField tvMap @@ -761,7 +761,7 @@ consFromJSON jc tName opts instTys cons = do [] ] - parseTaggedObject tvMap typFieldName valFieldName tagAsContentsFieldName obj = do + parseTaggedObject tvMap typFieldName valFieldName obj = do conKey <- newName "conKeyX" valField <- newName "valField" doE [ bindS (varP conKey) @@ -770,7 +770,7 @@ consFromJSON jc tName opts instTys cons = do ([|Key.fromString|] `appE` stringE typFieldName)) , letS [ valD (varP valField) ( normalB - $ if tagAsContentsFieldName + $ if null valFieldName then varE conKey else litE $ stringL valFieldName ) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index f27dceb73..a62a2251a 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1209,7 +1209,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) = TaggedObject{..} -> withObject tname $ \obj -> do tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey - let contentsFieldName' = if tagAsContentsFieldName + let contentsFieldName' = if null contentsFieldName then unpack tag else contentsFieldName fromMaybe (badTag tag Key tagKey) $ diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index fe068fe20..58a709875 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -761,9 +761,8 @@ instance Show Options where -- | Specifies how to encode constructors of a sum datatype. data SumEncoding = - TaggedObject { tagFieldName :: String - , contentsFieldName :: String - , tagAsContentsFieldName :: Bool + TaggedObject { tagFieldName :: String + , contentsFieldName :: String } -- ^ A constructor will be encoded to an object with a field -- 'tagFieldName' which specifies the constructor tag (modified by @@ -775,7 +774,7 @@ data SumEncoding = -- record the encoded constructor contents will be stored under -- the 'contentsFieldName' field. -- - -- If 'tagAsContentsFieldName' is True, then the value of + -- 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 @@ -868,9 +867,8 @@ defaultOptions = Options -- @ defaultTaggedObject :: SumEncoding defaultTaggedObject = TaggedObject - { tagFieldName = "tag" - , contentsFieldName = "contents" - , tagAsContentsFieldName = False + { tagFieldName = "tag" + , contentsFieldName = "contents" } -- | Default 'JSONKeyOptions': diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index 8ce7c2405..1fca2cebf 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/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) tagAsContentsFieldName + taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName) 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 -> Bool + -> Key -> Key -> f a -> enc instance ( TaggedObject enc arity a , TaggedObject enc arity b ) => TaggedObject enc arity (a :+: b) where - 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 + 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 {-# INLINE taggedObject #-} instance ( IsRecord a isRecord @@ -1005,14 +1005,14 @@ instance ( IsRecord a isRecord , Constructor c ) => TaggedObject enc arity (C1 c a) where - taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName = + taggedObject opts targs tagFieldName contentsFieldName = fromPairs . mappend tag . contents where constructorTagString = constructorTagModifier opts (conName (undefined :: t c a p)) tag = tagFieldName `pair` (fromString constructorTagString :: enc) - contentsFieldName' = if tagAsContentsFieldName - then Key.fromString constructorTagString - else contentsFieldName + contentsFieldName' = if null $ Key.toString contentsFieldName + then Key.fromString constructorTagString + else contentsFieldName contents = (unTagged :: Tagged isRecord pairs -> pairs) . taggedObject' opts targs contentsFieldName' . unM1 diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 46cf9b7b4..c9dda427e 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -280,7 +280,7 @@ showOptions = ++ ", allNullaryToStringTag = True" ++ ", omitNothingFields = False" ++ ", allowOmittedFields = True" - ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\", tagAsContentsFieldName = False}" + ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" ++ ", unwrapUnaryRecords = False" ++ ", tagSingleConstructors = False" ++ ", rejectUnknownFields = False"