Skip to content

Commit 79d3e9d

Browse files
bergmarkbergmark
authored
Merge pull request #520 from Lysxia/bug-517
Refactor TH derivation and fix #517
2 parents 299e658 + a72c382 commit 79d3e9d

File tree

3 files changed

+70
-65
lines changed

3 files changed

+70
-65
lines changed

‎Data/Aeson/TH.hs

Lines changed: 22 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -403,44 +403,27 @@ isNullary :: Con -> Bool
403403
isNullary (NormalC _ []) = True
404404
isNullary _ = False
405405

406-
sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp
407-
sumToValue opts multiCons conName exp
406+
sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
407+
sumToValue opts multiCons nullary conName exp
408408
| multiCons =
409409
case sumEncoding opts of
410410
TwoElemArray ->
411411
[|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
412412
TaggedObject{tagFieldName, contentsFieldName} ->
413-
[|A.object|] `appE` listE
414-
[ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
415-
, infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
416-
]
413+
let tag = infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
414+
contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
415+
in
416+
[|A.object|] `appE` listE (if nullary then [tag] else [tag, contents])
417417
ObjectWithSingleField ->
418418
[|A.object|] `appE` listE
419419
[ infixApp (conTxt opts conName) [|(.=)|] exp
420420
]
421+
UntaggedValue | nullary -> conStr opts conName
421422
UntaggedValue -> exp
422423
| otherwise = exp
423424

424-
nullarySumToValue :: Options -> Bool -> Name -> Q Exp
425-
nullarySumToValue opts multiCons conName =
426-
case sumEncoding opts of
427-
TaggedObject{tagFieldName} ->
428-
[|A.object|] `appE` listE
429-
[ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
430-
]
431-
UntaggedValue -> conStr opts conName
432-
_ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
433-
434425
-- | Generates code to generate the JSON encoding of a single constructor.
435426
argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
436-
-- Nullary constructors. Generates code that explicitly matches against the
437-
-- constructor even though it doesn't contain data. This is useful to prevent
438-
-- type errors.
439-
argsToValue jc tjs opts multiCons (NormalC conName []) = do
440-
([], _) <- reifyConTys jc tjs conName
441-
match (conP conName [])
442-
(normalB (nullarySumToValue opts multiCons conName))
443-
[]
444427

445428
-- Polyadic constructors with special case for unary constructors.
446429
argsToValue jc tjs opts multiCons (NormalC conName ts) = do
@@ -471,7 +454,7 @@ argsToValue jc tjs opts multiCons (NormalC conName ts) = do
471454
(varE 'V.create `appE`
472455
doE (newMV:stmts++[ret]))
473456
match (conP conName $ map varP args)
474-
(normalB $ sumToValue opts multiCons conName js)
457+
(normalB $ sumToValue opts multiCons (null ts) conName js)
475458
[]
476459

477460
-- Records.
@@ -538,7 +521,7 @@ argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
538521
ar <- newName "argR"
539522
match (infixP (varP al) conName (varP ar))
540523
( normalB
541-
$ sumToValue opts multiCons conName
524+
$ sumToValue opts multiCons False conName
542525
$ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy
543526
`appE` varE a
544527
| (a, aTy) <- [(al,alTy), (ar,arTy)]
@@ -580,48 +563,37 @@ array exp = [|E.wrapArray|] `appE` exp
580563
object :: ExpQ -> ExpQ
581564
object exp = [|E.wrapObject|] `appE` exp
582565

583-
sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
584-
sumToEncoding opts multiCons conName exp
566+
sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
567+
sumToEncoding opts multiCons nullary conName exp
585568
| multiCons =
586569
let fexp = exp in
587570
case sumEncoding opts of
588571
TwoElemArray ->
589572
array (encStr opts conName <%> fexp)
590573
TaggedObject{tagFieldName, contentsFieldName} ->
591-
object $
592-
([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>
593-
([|E.text (T.pack contentsFieldName)|] <:> fexp)
574+
let tag = [|E.text (T.pack tagFieldName)|] <:> encStr opts conName
575+
contents = [|E.text (T.pack contentsFieldName)|] <:> fexp
576+
in
577+
object $
578+
if nullary then tag else tag <%> contents
594579
ObjectWithSingleField ->
595580
object (encStr opts conName <:> fexp)
581+
UntaggedValue | nullary -> encStr opts conName
596582
UntaggedValue -> exp
597583
| otherwise = exp
598584

599-
nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp
600-
nullarySumToEncoding opts multiCons conName =
601-
case sumEncoding opts of
602-
TaggedObject{tagFieldName} ->
603-
object $
604-
[|E.text (T.pack tagFieldName)|] <:> encStr opts conName
605-
UntaggedValue -> encStr opts conName
606-
_ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
607-
608585
-- | Generates code to generate the JSON encoding of a single constructor.
609586
argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
610-
-- Nullary constructors. Generates code that explicitly matches against the
611-
-- constructor even though it doesn't contain data. This is useful to prevent
612-
-- type errors.
613-
argsToEncoding jc tes opts multiCons (NormalC conName []) = do
614-
([], _) <- reifyConTys jc tes conName
615-
match (conP conName [])
616-
(normalB (nullarySumToEncoding opts multiCons conName))
617-
[]
618587

619588
-- Polyadic constructors with special case for unary constructors.
620589
argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
621590
(argTys, tvMap) <- reifyConTys jc tes conName
622591
let len = length ts
623592
args <- newNameList "arg" len
624593
js <- case zip args argTys of
594+
-- Nullary constructors are converted to an empty array.
595+
[] -> return [| E.emptyArray_ |]
596+
625597
-- Single argument is directly converted.
626598
[(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy
627599
`appE` varE e)
@@ -632,7 +604,7 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
632604
| (x,xTy) <- es
633605
]))
634606
match (conP conName $ map varP args)
635-
(normalB $ sumToEncoding opts multiCons conName js)
607+
(normalB $ sumToEncoding opts multiCons (null ts) conName js)
636608
[]
637609

638610
-- Records.
@@ -701,7 +673,7 @@ argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
701673
([alTy,arTy], tvMap) <- reifyConTys jc tes conName
702674
match (infixP (varP al) conName (varP ar))
703675
( normalB
704-
$ sumToEncoding opts multiCons conName
676+
$ sumToEncoding opts multiCons False conName
705677
$ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy
706678
`appE` varE a
707679
| (a,aTy) <- [(al,alTy), (ar,arTy)]

‎tests/Encoders.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -341,3 +341,16 @@ thGADTToEncodingDefault = $(mkToEncoding defaultOptions ''GADT)
341341

342342
thGADTParseJSONDefault :: Value -> Parser (GADT String)
343343
thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT)
344+
345+
--------------------------------------------------------------------------------
346+
-- OneConstructor encoders/decoders
347+
--------------------------------------------------------------------------------
348+
349+
thOneConstructorToJSONDefault :: OneConstructor -> Value
350+
thOneConstructorToJSONDefault = $(mkToJSON defaultOptions ''OneConstructor)
351+
352+
thOneConstructorToEncodingDefault :: OneConstructor -> Encoding
353+
thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstructor)
354+
355+
thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor
356+
thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)

‎tests/Properties.hs

Lines changed: 35 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ import Instances ()
3333
import Numeric.Natural (Natural)
3434
import Test.Framework (Test, testGroup)
3535
import Test.Framework.Providers.QuickCheck2 (testProperty)
36-
import Test.QuickCheck (Arbitrary(..), Property, (===), (.&&.), counterexample)
36+
import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)
3737
import Types
3838
import qualified Data.Attoparsec.Lazy as L
3939
import qualified Data.ByteString.Lazy.Char8 as L
@@ -149,6 +149,11 @@ type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
149149
-- Value properties
150150
--------------------------------------------------------------------------------
151151

152+
-- | Add the formatted @Value@ to the printed counterexample when the property
153+
-- fails.
154+
checkValue :: Testable a => (Value -> a) -> Value -> Property
155+
checkValue prop v = counterexample (L.unpack (encode v)) (prop v)
156+
152157
isString :: Value -> Bool
153158
isString (String _) = True
154159
isString _ = False
@@ -182,6 +187,12 @@ isUntaggedValueETI (Number _) = True
182187
isUntaggedValueETI (Array a) = length a == 2
183188
isUntaggedValueETI _ = False
184189

190+
isEmptyArray :: Value -> Property
191+
isEmptyArray = checkValue isEmptyArray'
192+
193+
isEmptyArray' :: Value -> Bool
194+
isEmptyArray' = (Array mempty ==)
195+
185196

186197
--------------------------------------------------------------------------------
187198

@@ -410,21 +421,27 @@ tests = testGroup "properties" [
410421
, testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
411422

412423
]
413-
, testGroup "Approx" [
414-
testProperty "string" (isString . thApproxToJSONUnwrap)
415-
, testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
416-
, testGroup "roundTrip" [
417-
testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
418-
, testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
419-
]
424+
]
425+
, testGroup "Approx" [
426+
testProperty "string" (isString . thApproxToJSONUnwrap)
427+
, testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
428+
, testGroup "roundTrip" [
429+
testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
430+
, testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
420431
]
421-
, testGroup "GADT" [
422-
testProperty "string" (isString . thGADTToJSONUnwrap)
423-
, testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
424-
, testGroup "roundTrip" [
425-
testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
426-
, testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
427-
]
432+
]
433+
, testGroup "GADT" [
434+
testProperty "string" (isString . thGADTToJSONUnwrap)
435+
, testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
436+
, testGroup "roundTrip" [
437+
testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
438+
, testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
439+
]
440+
]
441+
, testGroup "OneConstructor" [
442+
testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
443+
, testGroup "roundTrip" [
444+
testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
428445
]
429446
]
430447
]
@@ -466,6 +483,9 @@ tests = testGroup "properties" [
466483
thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField
467484
, testProperty "SomeTypeObjectWithSingleField unary agree" $
468485
thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
486+
487+
, testProperty "OneConstructor" $
488+
thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
469489
]
470490
]
471491
]

0 commit comments

Comments
 (0)