Skip to content

Commit 55fe395

Browse files
wi11deywi11dey
committed
Add support for TaggedObject.tagAsContentsFieldName
1 parent cb75115 commit 55fe395

File tree

5 files changed

+53
-31
lines changed

5 files changed

+53
-31
lines changed

‎src/Data/Aeson/TH.hs

Lines changed: 26 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -407,11 +407,14 @@ sumToValue letInsert target opts multiCons nullary conName value pairs
407407
case sumEncoding opts of
408408
TwoElemArray ->
409409
array target [conStr target opts conName, value]
410-
TaggedObject{tagFieldName, contentsFieldName} ->
410+
TaggedObject{tagFieldName, contentsFieldName, tagAsContentsFieldName} ->
411411
-- TODO: Maybe throw an error in case
412412
-- tagFieldName overwrites a field in pairs.
413413
let tag = pairE letInsert target tagFieldName (conStr target opts conName)
414-
content = pairs contentsFieldName
414+
contentsFieldName' = if tagAsContentsFieldName
415+
then conString opts conName
416+
else contentsFieldName
417+
content = pairs contentsFieldName'
415418
in fromPairsE target $
416419
if nullary then tag else infixApp tag [|(Monoid.<>)|] content
417420
ObjectWithSingleField ->
@@ -715,8 +718,8 @@ consFromJSON jc tName opts instTys cons = do
715718

716719
mixedMatches tvMap =
717720
case sumEncoding opts of
718-
TaggedObject {tagFieldName, contentsFieldName} ->
719-
parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
721+
TaggedObject {tagFieldName, contentsFieldName, tagAsContentsFieldName} ->
722+
parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName tagAsContentsFieldName
720723
UntaggedValue -> error "UntaggedValue: Should be handled already"
721724
ObjectWithSingleField ->
722725
parseObject $ parseObjectWithSingleField tvMap
@@ -758,13 +761,22 @@ consFromJSON jc tName opts instTys cons = do
758761
[]
759762
]
760763

761-
parseTaggedObject tvMap typFieldName valFieldName obj = do
764+
parseTaggedObject tvMap typFieldName valFieldName tagAsContentsFieldName obj = do
762765
conKey <- newName "conKeyX"
766+
valField <- newName "valField"
763767
doE [ bindS (varP conKey)
764768
(infixApp (varE obj)
765769
[|(.:)|]
766770
([|Key.fromString|] `appE` stringE typFieldName))
767-
, noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
771+
, letS [ valD (varP valField)
772+
( normalB
773+
$ if tagAsContentsFieldName
774+
then varE conKey
775+
else litE $ stringL valFieldName
776+
)
777+
[]
778+
]
779+
, noBindS $ parseContents tvMap conKey (Left (valField, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
768780
]
769781

770782
parseUntaggedValue tvMap cons' conVal =
@@ -955,19 +967,19 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
955967
| (field, argTy) <- zip fields argTys
956968
]
957969

958-
getValField :: Name -> String -> [MatchQ] -> Q Exp
959-
getValField obj valFieldName matches = do
970+
getValField :: Name -> Name -> [MatchQ] -> Q Exp
971+
getValField obj valField matches = do
960972
val <- newName "val"
961973
doE [ bindS (varP val) $ infixApp (varE obj)
962974
[|(.:)|]
963975
([|Key.fromString|] `appE`
964-
litE (stringL valFieldName))
976+
varE valField)
965977
, noBindS $ caseE (varE val) matches
966978
]
967979

968-
matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
969-
matchCases (Left (valFieldName, obj)) = getValField obj valFieldName
970-
matchCases (Right valName) = caseE (varE valName)
980+
matchCases :: Either (Name, Name) Name -> [MatchQ] -> Q Exp
981+
matchCases (Left (valField, obj)) = getValField obj valField
982+
matchCases (Right valName) = caseE (varE valName)
971983

972984
-- | Generates code to parse the JSON encoding of a single constructor.
973985
parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
@@ -976,8 +988,8 @@ parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
976988
-> Name -- ^ Name of the type to which the constructor belongs.
977989
-> Options -- ^ Encoding options.
978990
-> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
979-
-> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
980-
-- Right valName
991+
-> Either (Name, Name) Name -- ^ Left (valFieldName, objName) or
992+
-- Right valName
981993
-> Q Exp
982994
-- Nullary constructors.
983995
parseArgs _ _ _ _

‎src/Data/Aeson/Types/FromJSON.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1209,8 +1209,11 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
12091209
TaggedObject{..} ->
12101210
withObject tname $ \obj -> do
12111211
tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1212+
let contentsFieldName' = if tagAsContentsFieldName
1213+
then unpack tag
1214+
else contentsFieldName
12121215
fromMaybe (badTag tag <?> Key tagKey) $
1213-
parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1216+
parseFromTaggedObject (tag :* contentsFieldName' :* p) obj
12141217
where
12151218
tagKey = Key.fromString tagFieldName
12161219
badTag tag = failWith_ $ \cnames ->

‎src/Data/Aeson/Types/Internal.hs

Lines changed: 9 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -761,8 +761,9 @@ instance Show Options where
761761

762762
-- | Specifies how to encode constructors of a sum datatype.
763763
data SumEncoding =
764-
TaggedObject { tagFieldName :: String
765-
, contentsFieldName :: String
764+
TaggedObject { tagFieldName :: String
765+
, contentsFieldName :: String
766+
, tagAsContentsFieldName :: Bool
766767
}
767768
-- ^ A constructor will be encoded to an object with a field
768769
-- 'tagFieldName' which specifies the constructor tag (modified by
@@ -773,6 +774,9 @@ data SumEncoding =
773774
-- by the encoded value of that field! If the constructor is not a
774775
-- record the encoded constructor contents will be stored under
775776
-- the 'contentsFieldName' field.
777+
--
778+
-- If 'tagAsContentsFieldName' is True, then the value of
779+
-- 'tagFieldName' will be used as the 'contentsFieldName' instead.
776780
| UntaggedValue
777781
-- ^ Constructor names won't be encoded. Instead only the contents of the
778782
-- constructor will be encoded as if the type had a single constructor. JSON
@@ -864,8 +868,9 @@ defaultOptions = Options
864868
-- @
865869
defaultTaggedObject :: SumEncoding
866870
defaultTaggedObject = TaggedObject
867-
{ tagFieldName = "tag"
868-
, contentsFieldName = "contents"
871+
{ tagFieldName = "tag"
872+
, contentsFieldName = "contents"
873+
, tagAsContentsFieldName = False
869874
}
870875

871876
-- | Default 'JSONKeyOptions':

‎src/Data/Aeson/Types/ToJSON.hs

Lines changed: 13 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -961,7 +961,7 @@ nonAllNullarySumToJSON opts targs =
961961
case sumEncoding opts of
962962

963963
TaggedObject{..} ->
964-
taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName)
964+
taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName) tagAsContentsFieldName
965965

966966
ObjectWithSingleField ->
967967
(unTagged :: Tagged ObjectWithSingleField enc -> enc)
@@ -984,17 +984,17 @@ nonAllNullarySumToJSON opts targs =
984984

985985
class TaggedObject enc arity f where
986986
taggedObject :: Options -> ToArgs enc arity a
987-
-> Key -> Key
987+
-> Key -> Key -> Bool
988988
-> f a -> enc
989989

990990
instance ( TaggedObject enc arity a
991991
, TaggedObject enc arity b
992992
) => TaggedObject enc arity (a :+: b)
993993
where
994-
taggedObject opts targs tagFieldName contentsFieldName (L1 x) =
995-
taggedObject opts targs tagFieldName contentsFieldName x
996-
taggedObject opts targs tagFieldName contentsFieldName (R1 x) =
997-
taggedObject opts targs tagFieldName contentsFieldName x
994+
taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName (L1 x) =
995+
taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName x
996+
taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName (R1 x) =
997+
taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName x
998998
{-# INLINE taggedObject #-}
999999

10001000
instance ( IsRecord a isRecord
@@ -1005,15 +1005,17 @@ instance ( IsRecord a isRecord
10051005
, Constructor c
10061006
) => TaggedObject enc arity (C1 c a)
10071007
where
1008-
taggedObject opts targs tagFieldName contentsFieldName =
1008+
taggedObject opts targs tagFieldName contentsFieldName tagAsContentsFieldName =
10091009
fromPairs . mappend tag . contents
10101010
where
1011-
tag = tagFieldName `pair`
1012-
(fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
1013-
:: enc)
1011+
constructorTagString = constructorTagModifier opts (conName (undefined :: t c a p))
1012+
tag = tagFieldName `pair` (fromString constructorTagString :: enc)
1013+
contentsFieldName' = if tagAsContentsFieldName
1014+
then Key.fromString constructorTagString
1015+
else contentsFieldName
10141016
contents =
10151017
(unTagged :: Tagged isRecord pairs -> pairs) .
1016-
taggedObject' opts targs contentsFieldName . unM1
1018+
taggedObject' opts targs contentsFieldName' . unM1
10171019
{-# INLINE taggedObject #-}
10181020

10191021
class TaggedObject' enc pairs arity f isRecord where

‎tests/UnitTests.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -280,7 +280,7 @@ showOptions =
280280
++ ", allNullaryToStringTag = True"
281281
++ ", omitNothingFields = False"
282282
++ ", allowOmittedFields = True"
283-
++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
283+
++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\", tagAsContentsFieldName = False}"
284284
++ ", unwrapUnaryRecords = False"
285285
++ ", tagSingleConstructors = False"
286286
++ ", rejectUnknownFields = False"

0 commit comments

Comments
 (0)