a72c382 · typeable/aeson

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 (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 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)]

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 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 | (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 ([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)]