c072f7a · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Nullary constructors ommit "contents" field in TaggedObject sumEncoding.

c072f7aEwout11 years ago

Data/Aeson/TH.hs+21−4

compare with master

unifiedsplit

@@ -312,6 +312,15 @@ sumToValue opts multiCons conName exp

312

313 | otherwise = exp

314

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+

315-- | Generates code to generate the JSON encoding of a single constructor.

324-- | Generates code to generate the JSON encoding of a single constructor.

316argsToValue :: Options -> Bool -> Con -> Q Match

325argsToValue :: Options -> Bool -> Con -> Q Match

317-- Nullary constructors. Generates code that explicitly matches against the

326-- Nullary constructors. Generates code that explicitly matches against the

@@ -319,7 +328,7 @@ argsToValue :: Options -> Bool -> Con -> Q Match

319-- type errors.

328-- type errors.

320argsToValue opts multiCons (NormalC conName []) =

329argsToValue opts multiCons (NormalC conName []) =

321 match (conP conName [])

330 match (conP conName [])

322− (normalB (sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]))

331+ (normalB (nullarySumToValue opts multiCons conName))

323 []

332 []

324

333

325-- Polyadic constructors with special case for unary constructors.

334-- Polyadic constructors with special case for unary constructors.

@@ -458,6 +467,14 @@ sumToEncoding opts multiCons conName exp

458

467

459 | otherwise = exp

468 | otherwise = exp

460

469

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+

461-- | Generates code to generate the JSON encoding of a single constructor.

478-- | Generates code to generate the JSON encoding of a single constructor.

462argsToEncoding :: Options -> Bool -> Con -> Q Match

479argsToEncoding :: Options -> Bool -> Con -> Q Match

463-- Nullary constructors. Generates code that explicitly matches against the

480-- Nullary constructors. Generates code that explicitly matches against the

@@ -465,7 +482,7 @@ argsToEncoding :: Options -> Bool -> Con -> Q Match

465-- type errors.

482-- type errors.

466argsToEncoding opts multiCons (NormalC conName []) =

483argsToEncoding opts multiCons (NormalC conName []) =

467 match (conP conName [])

484 match (conP conName [])

468− (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))

485+ (normalB (nullarySumToEncoding opts multiCons conName))

469 []

486 []

470

487

471-- Polyadic constructors with special case for unary constructors.

488-- Polyadic constructors with special case for unary constructors.

@@ -847,8 +864,8 @@ parseArgs :: Name -- ^ Name of the type to which the constructor belongs.

847 -- Right valName

864 -- Right valName

848 -> Q Exp

865 -> Q Exp

849-- Nullary constructors.

866-- Nullary constructors.

850−parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =

867+parseArgs _ _ (NormalC conName []) (Left _) =

851− getValField obj valFieldName $ parseNullaryMatches tName conName

868+ [|pure|] `appE` conE conName

852parseArgs tName _ (NormalC conName []) (Right valName) =

869parseArgs tName _ (NormalC conName []) (Right valName) =

853 caseE (varE valName) $ parseNullaryMatches tName conName

870 caseE (varE valName) $ parseNullaryMatches tName conName

854

871

Data/Aeson/Types/Generic.hs+11−3

@@ -206,6 +206,9 @@ instance ( IsRecord a isRecord

206class TaggedObjectPairs' f isRecord where

207 taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]

208

209+instance OVERLAPPING_ TaggedObjectPairs' U1 False where

210+ taggedObjectPairs' _ _ _ = Tagged []

211+

209instance (RecordToPairs f) => TaggedObjectPairs' f True where

212instance (RecordToPairs f) => TaggedObjectPairs' f True where

210 taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts

213 taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts

211

214

@@ -233,7 +236,6 @@ instance ( IsRecord a isRecord

233 (builder tagFieldName <>

236 (builder tagFieldName <>

234 B.char7 ':' <>

237 B.char7 ':' <>

235 builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>

238 builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>

236− B.char7 ',' <>

237 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .

239 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .

238 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>

240 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>

239 B.char7 '}'

241 B.char7 '}'

@@ -241,12 +243,15 @@ instance ( IsRecord a isRecord

241class TaggedObjectEnc' f isRecord where

243class TaggedObjectEnc' f isRecord where

242 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder

244 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder

243

245

246+instance OVERLAPPING_ TaggedObjectEnc' U1 False where

247+ taggedObjectEnc' _ _ _ = Tagged mempty

248+

244instance (RecordToEncoding f) => TaggedObjectEnc' f True where

249instance (RecordToEncoding f) => TaggedObjectEnc' f True where

245− taggedObjectEnc' opts _ = Tagged . recordToEncoding opts

250+ taggedObjectEnc' opts _ = Tagged . (\z -> B.char7 ',' <> recordToEncoding opts z)

246

251

247instance (GToEncoding f) => TaggedObjectEnc' f False where

252instance (GToEncoding f) => TaggedObjectEnc' f False where

248 taggedObjectEnc' opts contentsFieldName =

253 taggedObjectEnc' opts contentsFieldName =

249− Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .

254+ Tagged . (\z -> B.char7 ',' <> builder contentsFieldName <> B.char7 ':' <> z) .

250 gbuilder opts

255 gbuilder opts

251

256

252--------------------------------------------------------------------------------

257--------------------------------------------------------------------------------

@@ -627,6 +632,9 @@ instance (GFromJSON f) => FromTaggedObject'' f False where

627 parseFromTaggedObject'' opts contentsFieldName = Tagged .

632 parseFromTaggedObject'' opts contentsFieldName = Tagged .

628 (gParseJSON opts <=< (.: pack contentsFieldName))

633 (gParseJSON opts <=< (.: pack contentsFieldName))

629

634

635+instance OVERLAPPING_ FromTaggedObject'' U1 False where

636+ parseFromTaggedObject'' _ _ _ = Tagged (pure U1)

637+

630--------------------------------------------------------------------------------

638--------------------------------------------------------------------------------

631

639

632class ConsFromJSON f where

640class ConsFromJSON f where

tests/DataFamilies/Properties.hs+1−1

@@ -17,7 +17,7 @@ tests = testGroup "data families" [

17 testGroup "Nullary" [

18 testProperty "string" (isString . thNullaryToJSONString)

19 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)

20− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)

20+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)

21 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

23 , testGroup "roundTrip" [

tests/Properties.hs+5−2

@@ -104,6 +104,9 @@ isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&

104 "contents" `H.member` obj

105isTaggedObjectValue _ = False

106

107+isNullaryTaggedObject :: Value -> Bool

108+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj

109+

107isTaggedObject :: Value -> Bool

110isTaggedObject :: Value -> Bool

108isTaggedObject (Object obj) = "tag" `H.member` obj

111isTaggedObject (Object obj) = "tag" `H.member` obj

109isTaggedObject _ = False

112isTaggedObject _ = False

@@ -158,7 +161,7 @@ tests = testGroup "properties" [

158 testGroup "Nullary" [

161 testGroup "Nullary" [

159 testProperty "string" (isString . gNullaryToJSONString)

162 testProperty "string" (isString . gNullaryToJSONString)

160 , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)

163 , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)

161− , testProperty "TaggedObject" (isTaggedObject . gNullaryToJSONTaggedObject)

164+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)

162 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)

165 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)

163 , testGroup "roundTrip" [

166 , testGroup "roundTrip" [

164 testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)

167 testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)

@@ -206,7 +209,7 @@ tests = testGroup "properties" [

206 testGroup "Nullary" [

209 testGroup "Nullary" [

207 testProperty "string" (isString . thNullaryToJSONString)

210 testProperty "string" (isString . thNullaryToJSONString)

208 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)

211 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)

209− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)

212+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)

210 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

213 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

211

214

212 , testGroup "roundTrip" [

215 , testGroup "roundTrip" [