22064e4 · typeable/aeson

Data/Aeson/TH.hs+5−3

compare with master

unifiedsplit

@@ -341,7 +341,7 @@ consToValue jc opts cons = do

341 matches tjs = case cons of

342 -- A single constructor is directly encoded. The constructor itself may be

343 -- forgotten.

344− [con] -> [argsToValue jc tjs opts False con]

344+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]

345 _ | allNullaryToStringTag opts && all isNullary cons ->

346 [ match (conP conName []) (normalB $ conStr opts conName) []

347 | con <- cons

@@ -384,7 +384,7 @@ consToEncoding jc opts cons = do

384 matches tes = case cons of

385 -- A single constructor is directly encoded. The constructor itself may be

386 -- forgotten.

387− [con] -> [argsToEncoding jc tes opts False con]

387+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]

388 -- Encode just the name of the constructor of a sum type iff all the

389 -- constructors are nullary.

390 _ | allNullaryToStringTag opts && all isNullary cons ->

@@ -792,7 +792,9 @@ consFromJSON jc tName opts cons = do

792

793 where

794 lamExpr value pjs = case cons of

795+ [con]

796+ | not (tagSingleConstructors opts)

795− [con] -> parseArgs jc pjs tName opts con (Right value)

797+ -> parseArgs jc pjs tName opts con (Right value)

796 _ | sumEncoding opts == UntaggedValue

798 _ | sumEncoding opts == UntaggedValue

797 -> parseUntaggedValue pjs cons value

799 -> parseUntaggedValue pjs cons value

798 | otherwise

800 | otherwise

Data/Aeson/Types/FromJSON.hs+26−13

@@ -791,6 +791,19 @@ instance GFromJSON arity U1 where

791 | isEmptyArray v = pure U1

792 | otherwise = typeMismatch "unit constructor (U1)" v

793

794+instance ( ConsFromJSON arity a

795+ , AllNullary (C1 c a) allNullary

796+ , ParseSum arity (C1 c a) allNullary

797+ ) => GFromJSON arity (D1 d (C1 c a)) where

798+ -- The option 'tagSingleConstructors' determines whether to wrap

799+ -- a single-constructor type.

800+ gParseJSON opts fargs

801+ | tagSingleConstructors opts

802+ = fmap M1

803+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))

804+ . parseSum opts fargs

805+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs

806+

794instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where

807instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where

795 -- Constructors need to be decoded differently depending on whether they're

808 -- Constructors need to be decoded differently depending on whether they're

796 -- a record or not. This distinction is made by consParseJSON:

809 -- a record or not. This distinction is made by consParseJSON:

@@ -837,19 +850,19 @@ class ParseSum arity f allNullary where

837 parseSum :: Options -> FromArgs arity a

850 parseSum :: Options -> FromArgs arity a

838 -> Value -> Tagged allNullary (Parser (f a))

851 -> Value -> Tagged allNullary (Parser (f a))

839

852

840−instance ( SumFromString (a :+: b)

853+instance ( SumFromString f

841− , FromPair arity (a :+: b)

854+ , FromPair arity f

842− , FromTaggedObject arity (a :+: b)

855+ , FromTaggedObject arity f

843− , FromUntaggedValue arity (a :+: b)

856+ , FromUntaggedValue arity f

844− ) => ParseSum arity (a :+: b) True where

857+ ) => ParseSum arity f True where

845 parseSum opts fargs

858 parseSum opts fargs

846 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

859 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

847 | otherwise = Tagged . parseNonAllNullarySum opts fargs

860 | otherwise = Tagged . parseNonAllNullarySum opts fargs

848

861

849−instance ( FromPair arity (a :+: b)

862+instance ( FromPair arity f

850− , FromTaggedObject arity (a :+: b)

863+ , FromTaggedObject arity f

851− , FromUntaggedValue arity (a :+: b)

864+ , FromUntaggedValue arity f

852− ) => ParseSum arity (a :+: b) False where

865+ ) => ParseSum arity f False where

853 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

866 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

854

867

855--------------------------------------------------------------------------------

868--------------------------------------------------------------------------------

@@ -875,11 +888,11 @@ instance (Constructor c) => SumFromString (C1 c U1) where

875

888

876--------------------------------------------------------------------------------

889--------------------------------------------------------------------------------

877

890

878−parseNonAllNullarySum :: ( FromPair arity (a :+: b)

891+parseNonAllNullarySum :: ( FromPair arity f

879− , FromTaggedObject arity (a :+: b)

892+ , FromTaggedObject arity f

880− , FromUntaggedValue arity (a :+: b)

893+ , FromUntaggedValue arity f

881 ) => Options -> FromArgs arity c

894 ) => Options -> FromArgs arity c

882− -> Value -> Parser ((a :+: b) c)

895+ -> Value -> Parser (f c)

883parseNonAllNullarySum opts fargs =

896parseNonAllNullarySum opts fargs =

884 case sumEncoding opts of

897 case sumEncoding opts of

885 TaggedObject{..} ->

898 TaggedObject{..} ->

Data/Aeson/Types/Internal.hs+7−1

@@ -524,10 +524,13 @@ data Options = Options

524 , unwrapUnaryRecords :: Bool

525 -- ^ Hide the field name when a record constructor has only one

526 -- field, like a newtype.

527+ , tagSingleConstructors :: Bool

528+ -- ^ Encode types with a single constructor as sums,

529+ -- so that `allNullaryToStringTag` and `sumEncoding` apply.

527 }

530 }

528

531

529instance Show Options where

532instance Show Options where

530− show (Options f c a o s u) =

533+ show (Options f c a o s u t) =

531 "Options {"

534 "Options {"

532 ++ intercalate ", "

535 ++ intercalate ", "

533 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

536 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

@@ -536,6 +539,7 @@ instance Show Options where

536 , "omitNothingFields = " ++ show o

539 , "omitNothingFields = " ++ show o

537 , "sumEncoding = " ++ show s

540 , "sumEncoding = " ++ show s

538 , "unwrapUnaryRecords = " ++ show u

541 , "unwrapUnaryRecords = " ++ show u

542+ , "tagSingleConstructors = " ++ show t

539 ]

543 ]

540 ++ "}"

544 ++ "}"

541

545

@@ -589,6 +593,7 @@ data SumEncoding =

589-- , 'omitNothingFields' = False

593-- , 'omitNothingFields' = False

590-- , 'sumEncoding' = 'defaultTaggedObject'

594-- , 'sumEncoding' = 'defaultTaggedObject'

591-- , 'unwrapUnaryRecords' = False

595-- , 'unwrapUnaryRecords' = False

596+-- , 'tagSingleConstructors' = False

592-- }

597-- }

593-- @

598-- @

594defaultOptions :: Options

599defaultOptions :: Options

@@ -599,6 +604,7 @@ defaultOptions = Options

599 , omitNothingFields = False

604 , omitNothingFields = False

600 , sumEncoding = defaultTaggedObject

605 , sumEncoding = defaultTaggedObject

601 , unwrapUnaryRecords = False

606 , unwrapUnaryRecords = False

607+ , tagSingleConstructors = False

602 }

608 }

603

609

604-- | Default 'TaggedObject' 'SumEncoding' options:

610-- | Default 'TaggedObject' 'SumEncoding' options:

Data/Aeson/Types/ToJSON.hs+12

@@ -659,6 +659,18 @@ instance GToJSON enc One Par1 where

659 -- function passed in as an argument:

660 gToJSON _opts (To1Args tj _) = tj . unPar1

661

662+instance ( ConsToJSON enc arity a

663+ , AllNullary (C1 c a) allNullary

664+ , SumToJSON enc arity (C1 c a) allNullary

665+ ) => GToJSON enc arity (D1 d (C1 c a)) where

666+ -- The option 'tagSingleConstructors' determines whether to wrap

667+ -- a single-constructor type.

668+ gToJSON opts targs

669+ | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)

670+ . sumToJSON opts targs

671+ . unM1

672+ | otherwise = consToJSON opts targs . unM1 . unM1

673+

662instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where

674instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where

663 -- Constructors need to be encoded differently depending on whether they're

675 -- Constructors need to be encoded differently depending on whether they're

664 -- a record or not. This distinction is made by 'consToJSON':

676 -- a record or not. This distinction is made by 'consToJSON':

tests/Encoders.hs+28

@@ -354,3 +354,31 @@ thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstruct

354

355thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor

356thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)

357+

358+thOneConstructorToJSONTagged :: OneConstructor -> Value

359+thOneConstructorToJSONTagged = $(mkToJSON optsTagSingleConstructors ''OneConstructor)

360+

361+thOneConstructorToEncodingTagged :: OneConstructor -> Encoding

362+thOneConstructorToEncodingTagged = $(mkToEncoding optsTagSingleConstructors ''OneConstructor)

363+

364+thOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

365+thOneConstructorParseJSONTagged = $(mkParseJSON optsTagSingleConstructors ''OneConstructor)

366+

367+

368+gOneConstructorToJSONDefault :: OneConstructor -> Value

369+gOneConstructorToJSONDefault = genericToJSON defaultOptions

370+

371+gOneConstructorToEncodingDefault :: OneConstructor -> Encoding

372+gOneConstructorToEncodingDefault = genericToEncoding defaultOptions

373+

374+gOneConstructorParseJSONDefault :: Value -> Parser OneConstructor

375+gOneConstructorParseJSONDefault = genericParseJSON defaultOptions

376+

377+gOneConstructorToJSONTagged :: OneConstructor -> Value

378+gOneConstructorToJSONTagged = genericToJSON optsTagSingleConstructors

379+

380+gOneConstructorToEncodingTagged :: OneConstructor -> Encoding

381+gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors

382+

383+gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

384+gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors

tests/Options.hs+6

@@ -42,3 +42,9 @@ optsUntaggedValue :: Options

42optsUntaggedValue = optsDefault

43 { sumEncoding = UntaggedValue

44 }

45+

46+optsTagSingleConstructors :: Options

47+optsTagSingleConstructors = optsDefault

48+ { tagSingleConstructors = True

49+ , allNullaryToStringTag = False

50+ }

tests/Properties.hs+25−5

@@ -168,11 +168,14 @@ isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&

168isTaggedObjectValue _ = False

169

170isNullaryTaggedObject :: Value -> Bool

171−isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj

171+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj

172

173−isTaggedObject :: Value -> Bool

173+isTaggedObject :: Value -> Property

174+isTaggedObject = checkValue isTaggedObject'

175+

176+isTaggedObject' :: Value -> Bool

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

177+isTaggedObject' (Object obj) = "tag" `H.member` obj

175−isTaggedObject _ = False

178+isTaggedObject' _ = False

176

179

177isObjectWithSingleField :: Value -> Bool

180isObjectWithSingleField :: Value -> Bool

178isObjectWithSingleField (Object obj) = H.size obj == 1

181isObjectWithSingleField (Object obj) = H.size obj == 1

@@ -338,6 +341,14 @@ tests = testGroup "properties" [

338#endif

341#endif

339 ]

342 ]

340 ]

343 ]

344+ , testGroup "OneConstructor" [

345+ testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)

346+ , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)

347+ , testGroup "roundTrip" [

348+ testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)

349+ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)

350+ ]

351+ ]

341 ]

352 ]

342 , testGroup "toEncoding" [

353 , testGroup "toEncoding" [

343 testProperty "NullaryString" $

354 testProperty "NullaryString" $

@@ -386,6 +397,11 @@ tests = testGroup "properties" [

386

397

387 , testProperty "SomeTypeOmitNothingFields" $

398 , testProperty "SomeTypeOmitNothingFields" $

388 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

399 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

400+

401+ , testProperty "OneConstructorDefault" $

402+ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault

403+ , testProperty "OneConstructorTagged" $

404+ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged

389 ]

405 ]

390 ]

406 ]

391 , testGroup "template-haskell" [

407 , testGroup "template-haskell" [

@@ -440,8 +456,10 @@ tests = testGroup "properties" [

440 ]

456 ]

441 , testGroup "OneConstructor" [

457 , testGroup "OneConstructor" [

442 testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)

458 testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)

459+ , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)

443 , testGroup "roundTrip" [

460 , testGroup "roundTrip" [

444 testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)

461 testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)

462+ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)

445 ]

463 ]

446 ]

464 ]

447 ]

465 ]

@@ -484,8 +502,10 @@ tests = testGroup "properties" [

484 , testProperty "SomeTypeObjectWithSingleField unary agree" $

502 , testProperty "SomeTypeObjectWithSingleField unary agree" $

485 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

503 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

486

504

487− , testProperty "OneConstructor" $

505+ , testProperty "OneConstructorDefault" $

488 thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault

506 thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault

507+ , testProperty "OneConstructorTagged" $

508+ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged

489 ]

509 ]

490 ]

510 ]

491 ]

511 ]

tests/UnitTests.hs+1

@@ -494,6 +494,7 @@ showOptions =

494 ++ ", omitNothingFields = False"

495 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"

496 ++ ", unwrapUnaryRecords = False"

497+ ++ ", tagSingleConstructors = False"

497 ++ "}")

498 ++ "}")

498 (show defaultOptions)

499 (show defaultOptions)

499

500