git.iko.soy/typeable/aeson
on master help sign in
Nullary constructors ommit "contents" field in TaggedObject sumEncoding.
commitc072f7a88aa6831a632034f701ef9d93a9b73772 authorEwout <e@ewout.name> dateTue 20 Oct 2015, 02:14 (11 years ago) parent4d1e71d
4 files changed+38−10
compare with master
unifiedsplit
Data/Aeson/TH.hs+21−4 Data/Aeson/Types/Generic.hs+11−3 tests/DataFamilies/Properties.hs+1−1 tests/Properties.hs+5−2
Data/Aeson/TH.hs+21−4
@@ -312,6 +312,15 @@ sumToValue opts multiCons conName exp
312312
313313 | otherwise = exp
314314
315+nullarySumToValue :: Options -> Bool -> Name -> Q Exp
316+nullarySumToValue opts multiCons conName =
317+ case sumEncoding opts of
318+ TaggedObject{tagFieldName} ->
319+ [|A.object|] `appE` listE
320+ [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
321+ ]
322+ _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
323+
315324-- | Generates code to generate the JSON encoding of a single constructor.
316325argsToValue :: Options -> Bool -> Con -> Q Match
317326-- Nullary constructors. Generates code that explicitly matches against the
@@ -319,7 +328,7 @@ argsToValue :: Options -> Bool -> Con -> Q Match
319328-- type errors.
320329argsToValue opts multiCons (NormalC conName []) =
321330 match (conP conName [])
322− (normalB (sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]))
331+ (normalB (nullarySumToValue opts multiCons conName))
323332 []
324333
325334-- Polyadic constructors with special case for unary constructors.
@@ -458,6 +467,14 @@ sumToEncoding opts multiCons conName exp
458467
459468 | otherwise = exp
460469
470+nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp
471+nullarySumToEncoding opts multiCons conName =
472+ case sumEncoding opts of
473+ TaggedObject{tagFieldName} ->
474+ object $
475+ ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName)
476+ _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
477+
461478-- | Generates code to generate the JSON encoding of a single constructor.
462479argsToEncoding :: Options -> Bool -> Con -> Q Match
463480-- Nullary constructors. Generates code that explicitly matches against the
@@ -465,7 +482,7 @@ argsToEncoding :: Options -> Bool -> Con -> Q Match
465482-- type errors.
466483argsToEncoding opts multiCons (NormalC conName []) =
467484 match (conP conName [])
468− (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))
485+ (normalB (nullarySumToEncoding opts multiCons conName))
469486 []
470487
471488-- Polyadic constructors with special case for unary constructors.
@@ -847,8 +864,8 @@ parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
847864 -- Right valName
848865 -> Q Exp
849866-- Nullary constructors.
850−parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
851− getValField obj valFieldName $ parseNullaryMatches tName conName
867+parseArgs _ _ (NormalC conName []) (Left _) =
868+ [|pure|] `appE` conE conName
852869parseArgs tName _ (NormalC conName []) (Right valName) =
853870 caseE (varE valName) $ parseNullaryMatches tName conName
854871
Data/Aeson/Types/Generic.hs+11−3
@@ -206,6 +206,9 @@ instance ( IsRecord a isRecord
206206class TaggedObjectPairs' f isRecord where
207207 taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
208208
209+instance OVERLAPPING_ TaggedObjectPairs' U1 False where
210+ taggedObjectPairs' _ _ _ = Tagged []
211+
209212instance (RecordToPairs f) => TaggedObjectPairs' f True where
210213 taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
211214
@@ -233,7 +236,6 @@ instance ( IsRecord a isRecord
233236 (builder tagFieldName <>
234237 B.char7 ':' <>
235238 builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
236− B.char7 ',' <>
237239 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
238240 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
239241 B.char7 '}'
@@ -241,12 +243,15 @@ instance ( IsRecord a isRecord
241243class TaggedObjectEnc' f isRecord where
242244 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
243245
246+instance OVERLAPPING_ TaggedObjectEnc' U1 False where
247+ taggedObjectEnc' _ _ _ = Tagged mempty
248+
244249instance (RecordToEncoding f) => TaggedObjectEnc' f True where
245− taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
250+ taggedObjectEnc' opts _ = Tagged . (\z -> B.char7 ',' <> recordToEncoding opts z)
246251
247252instance (GToEncoding f) => TaggedObjectEnc' f False where
248253 taggedObjectEnc' opts contentsFieldName =
249− Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
254+ Tagged . (\z -> B.char7 ',' <> builder contentsFieldName <> B.char7 ':' <> z) .
250255 gbuilder opts
251256
252257--------------------------------------------------------------------------------
@@ -627,6 +632,9 @@ instance (GFromJSON f) => FromTaggedObject'' f False where
627632 parseFromTaggedObject'' opts contentsFieldName = Tagged .
628633 (gParseJSON opts <=< (.: pack contentsFieldName))
629634
635+instance OVERLAPPING_ FromTaggedObject'' U1 False where
636+ parseFromTaggedObject'' _ _ _ = Tagged (pure U1)
637+
630638--------------------------------------------------------------------------------
631639
632640class ConsFromJSON f where
tests/DataFamilies/Properties.hs+1−1
@@ -17,7 +17,7 @@ tests = testGroup "data families" [
1717 testGroup "Nullary" [
1818 testProperty "string" (isString . thNullaryToJSONString)
1919 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
20− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
20+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
2121 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
2222
2323 , testGroup "roundTrip" [
tests/Properties.hs+5−2
@@ -104,6 +104,9 @@ isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
104104 "contents" `H.member` obj
105105isTaggedObjectValue _ = False
106106
107+isNullaryTaggedObject :: Value -> Bool
108+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
109+
107110isTaggedObject :: Value -> Bool
108111isTaggedObject (Object obj) = "tag" `H.member` obj
109112isTaggedObject _ = False
@@ -158,7 +161,7 @@ tests = testGroup "properties" [
158161 testGroup "Nullary" [
159162 testProperty "string" (isString . gNullaryToJSONString)
160163 , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
161− , testProperty "TaggedObject" (isTaggedObject . gNullaryToJSONTaggedObject)
164+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
162165 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
163166 , testGroup "roundTrip" [
164167 testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
@@ -206,7 +209,7 @@ tests = testGroup "properties" [
206209 testGroup "Nullary" [
207210 testProperty "string" (isString . thNullaryToJSONString)
208211 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
209− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
212+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
210213 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
211214
212215 , testGroup "roundTrip" [