diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 088b1fba..a06661b2 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 7fbacaea..f27dceb7 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 758f5fc4..fe068fe2 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 a0900ed3..8ce7c240 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 c9dda427..46cf9b7b 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"