79d3e9d · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #520 from Lysxia/bug-517

79d3e9dAdam Bergmark10 years ago

Data/Aeson/TH.hs+22−50

compare with master

unifiedsplit

@@ -403,44 +403,27 @@ isNullary :: Con -> Bool

403isNullary (NormalC _ []) = True

404isNullary _ = False

405

406−sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp

406+sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp

407−sumToValue opts multiCons conName exp

407+sumToValue opts multiCons nullary conName exp

408 | multiCons =

409 case sumEncoding opts of

410 TwoElemArray ->

411 [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])

412 TaggedObject{tagFieldName, contentsFieldName} ->

413− [|A.object|] `appE` listE

414− [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)

413+ let tag = infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)

415− , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp

414+ contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp

416− ]

415+ in

416+ [|A.object|] `appE` listE (if nullary then [tag] else [tag, contents])

417 ObjectWithSingleField ->

418 [|A.object|] `appE` listE

419 [ infixApp (conTxt opts conName) [|(.=)|] exp

420 ]

421+ UntaggedValue | nullary -> conStr opts conName

421 UntaggedValue -> exp

422 UntaggedValue -> exp

422 | otherwise = exp

423 | otherwise = exp

423

424

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−

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

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

435argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match

426argsToValue :: 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− []

444

427

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

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

446argsToValue jc tjs opts multiCons (NormalC conName ts) = do

429argsToValue jc tjs opts multiCons (NormalC conName ts) = do

@@ -471,7 +454,7 @@ argsToValue jc tjs opts multiCons (NormalC conName ts) = do

471 (varE 'V.create `appE`

454 (varE 'V.create `appE`

472 doE (newMV:stmts++[ret]))

455 doE (newMV:stmts++[ret]))

473 match (conP conName $ map varP args)

456 match (conP conName $ map varP args)

474− (normalB $ sumToValue opts multiCons conName js)

457+ (normalB $ sumToValue opts multiCons (null ts) conName js)

475 []

458 []

476

459

477-- Records.

460-- Records.

@@ -538,7 +521,7 @@ argsToValue jc tjs opts multiCons (InfixC _ conName _) = do

538 ar <- newName "argR"

521 ar <- newName "argR"

539 match (infixP (varP al) conName (varP ar))

522 match (infixP (varP al) conName (varP ar))

540 ( normalB

523 ( normalB

541− $ sumToValue opts multiCons conName

524+ $ sumToValue opts multiCons False conName

542 $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy

525 $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy

543 `appE` varE a

526 `appE` varE a

544 | (a, aTy) <- [(al,alTy), (ar,arTy)]

527 | (a, aTy) <- [(al,alTy), (ar,arTy)]

@@ -580,41 +563,27 @@ array exp = [|E.wrapArray|] `appE` exp

580object :: ExpQ -> ExpQ

563object :: ExpQ -> ExpQ

581object exp = [|E.wrapObject|] `appE` exp

564object exp = [|E.wrapObject|] `appE` exp

582

565

583−sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp

566+sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp

584−sumToEncoding opts multiCons conName exp

567+sumToEncoding opts multiCons nullary conName exp

585 | multiCons =

568 | multiCons =

586 let fexp = exp in

569 let fexp = exp in

587 case sumEncoding opts of

570 case sumEncoding opts of

588 TwoElemArray ->

571 TwoElemArray ->

589 array (encStr opts conName <%> fexp)

572 array (encStr opts conName <%> fexp)

590 TaggedObject{tagFieldName, contentsFieldName} ->

573 TaggedObject{tagFieldName, contentsFieldName} ->

591− object $

592− ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>

574+ let tag = [|E.text (T.pack tagFieldName)|] <:> encStr opts conName

593− ([|E.text (T.pack contentsFieldName)|] <:> fexp)

575+ contents = [|E.text (T.pack contentsFieldName)|] <:> fexp

576+ in

577+ object $

578+ if nullary then tag else tag <%> contents

594 ObjectWithSingleField ->

579 ObjectWithSingleField ->

595 object (encStr opts conName <:> fexp)

580 object (encStr opts conName <:> fexp)

581+ UntaggedValue | nullary -> encStr opts conName

596 UntaggedValue -> exp

582 UntaggedValue -> exp

597 | otherwise = exp

583 | otherwise = exp

598

584

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−

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

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

609argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match

586argsToEncoding :: 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− []

618

587

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

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

620argsToEncoding jc tes opts multiCons (NormalC conName ts) = do

589argsToEncoding jc tes opts multiCons (NormalC conName ts) = do

@@ -622,6 +591,9 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do

622 let len = length ts

591 let len = length ts

623 args <- newNameList "arg" len

592 args <- newNameList "arg" len

624 js <- case zip args argTys of

593 js <- case zip args argTys of

594+ -- Nullary constructors are converted to an empty array.

595+ [] -> return [| E.emptyArray_ |]

596+

625 -- Single argument is directly converted.

597 -- Single argument is directly converted.

626 [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy

598 [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy

627 `appE` varE e)

599 `appE` varE e)

@@ -632,7 +604,7 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do

632 | (x,xTy) <- es

604 | (x,xTy) <- es

633 ]))

605 ]))

634 match (conP conName $ map varP args)

606 match (conP conName $ map varP args)

635− (normalB $ sumToEncoding opts multiCons conName js)

607+ (normalB $ sumToEncoding opts multiCons (null ts) conName js)

636 []

608 []

637

609

638-- Records.

610-- Records.

@@ -701,7 +673,7 @@ argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do

701 ([alTy,arTy], tvMap) <- reifyConTys jc tes conName

673 ([alTy,arTy], tvMap) <- reifyConTys jc tes conName

702 match (infixP (varP al) conName (varP ar))

674 match (infixP (varP al) conName (varP ar))

703 ( normalB

675 ( normalB

704− $ sumToEncoding opts multiCons conName

676+ $ sumToEncoding opts multiCons False conName

705 $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy

677 $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy

706 `appE` varE a

678 `appE` varE a

707 | (a,aTy) <- [(al,alTy), (ar,arTy)]

679 | (a,aTy) <- [(al,alTy), (ar,arTy)]

tests/Encoders.hs+13

@@ -341,3 +341,16 @@ thGADTToEncodingDefault = $(mkToEncoding defaultOptions ''GADT)

341

342thGADTParseJSONDefault :: Value -> Parser (GADT String)

343thGADTParseJSONDefault = $(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+35−15

@@ -33,7 +33,7 @@ import Instances ()

33import Numeric.Natural (Natural)

34import Test.Framework (Test, testGroup)

35import Test.Framework.Providers.QuickCheck2 (testProperty)

36−import Test.QuickCheck (Arbitrary(..), Property, (===), (.&&.), counterexample)

36+import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)

37import Types

38import qualified Data.Attoparsec.Lazy as L

39import qualified Data.ByteString.Lazy.Char8 as L

@@ -149,6 +149,11 @@ type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)

149-- Value properties

150--------------------------------------------------------------------------------

151

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+

152isString :: Value -> Bool

157isString :: Value -> Bool

153isString (String _) = True

158isString (String _) = True

154isString _ = False

159isString _ = False

@@ -182,6 +187,12 @@ isUntaggedValueETI (Number _) = True

182isUntaggedValueETI (Array a) = length a == 2

187isUntaggedValueETI (Array a) = length a == 2

183isUntaggedValueETI _ = False

188isUntaggedValueETI _ = False

184

189

190+isEmptyArray :: Value -> Property

191+isEmptyArray = checkValue isEmptyArray'

192+

193+isEmptyArray' :: Value -> Bool

194+isEmptyArray' = (Array mempty ==)

195+

185

196

186--------------------------------------------------------------------------------

197--------------------------------------------------------------------------------

187

198

@@ -410,21 +421,27 @@ tests = testGroup "properties" [

410 , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)

421 , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)

411

422

412 ]

423 ]

424+ ]

413− , testGroup "Approx" [

425+ , testGroup "Approx" [

414− testProperty "string" (isString . thApproxToJSONUnwrap)

426+ testProperty "string" (isString . thApproxToJSONUnwrap)

415− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)

427+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)

416− , testGroup "roundTrip" [

428+ , testGroup "roundTrip" [

417− testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)

429+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)

418− , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)

430+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)

419− ]

420 ]

431 ]

432+ ]

421− , testGroup "GADT" [

433+ , testGroup "GADT" [

422− testProperty "string" (isString . thGADTToJSONUnwrap)

434+ testProperty "string" (isString . thGADTToJSONUnwrap)

423− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)

435+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)

424− , testGroup "roundTrip" [

436+ , testGroup "roundTrip" [

425− testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)

437+ testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)

426− , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)

438+ , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)

439+ ]

427− ]

440+ ]

441+ , testGroup "OneConstructor" [

442+ testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)

443+ , testGroup "roundTrip" [

444+ testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)

428 ]

445 ]

429 ]

446 ]

430 ]

447 ]

@@ -466,6 +483,9 @@ tests = testGroup "properties" [

466 thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField

483 thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField

467 , testProperty "SomeTypeObjectWithSingleField unary agree" $

484 , testProperty "SomeTypeObjectWithSingleField unary agree" $

468 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

485 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

486+

487+ , testProperty "OneConstructor" $

488+ thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault

469 ]

489 ]

470 ]

490 ]

471 ]

491 ]