4904205 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #443 from phadej/untagged-value

4904205Adam Bergmark10 years ago

Data/Aeson/TH.hs+33−4

compare with master

unifiedsplit

@@ -112,7 +112,7 @@ module Data.Aeson.TH

112 , mkLiftParseJSON2

113 ) where

114

115−import Control.Applicative ( pure, (<$>), (<*>) )

115+import Control.Applicative ( pure, (<$>), (<*>), (<|>) )

116import Data.Aeson ( Object, (.=), (.:)

117 , ToJSON(..), FromJSON(..)

118 , ToJSON1(..), FromJSON1(..)

@@ -437,7 +437,7 @@ sumToValue opts multiCons conName exp

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

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

439 ]

440−

440+ UntaggedValue -> exp

441 | otherwise = exp

442

443nullarySumToValue :: Options -> Bool -> Name -> Q Exp

@@ -447,6 +447,7 @@ nullarySumToValue opts multiCons conName =

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

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

449 ]

450+ UntaggedValue -> conStr opts conName

450 _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]

451 _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]

451

452

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

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

@@ -545,6 +546,7 @@ argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords o

545 ObjectWithSingleField ->

546 ObjectWithSingleField ->

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

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

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

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

549+ UntaggedValue -> exp

548 else exp

550 else exp

549 ) []

551 ) []

550

552

@@ -610,7 +612,7 @@ sumToEncoding opts multiCons conName exp

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

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

611 ObjectWithSingleField ->

613 ObjectWithSingleField ->

612 object (encStr opts conName <:> fexp)

614 object (encStr opts conName <:> fexp)

613−

615+ UntaggedValue -> exp

614 | otherwise = exp

616 | otherwise = exp

615

617

616nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp

618nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp

@@ -619,6 +621,7 @@ nullarySumToEncoding opts multiCons conName =

619 TaggedObject{tagFieldName} ->

621 TaggedObject{tagFieldName} ->

620 object $

622 object $

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

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

624+ UntaggedValue -> encStr opts conName

622 _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]

625 _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]

623

626

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

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

@@ -706,6 +709,7 @@ argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecord

706 objBody

709 objBody

707 ObjectWithSingleField -> object $

710 ObjectWithSingleField -> object $

708 encStr opts conName <:> exp

711 encStr opts conName <:> exp

712+ UntaggedValue -> exp

709 else exp

713 else exp

710 ) []

714 ) []

711

715

@@ -836,7 +840,10 @@ consFromJSON jc tName opts cons = do

836 where

840 where

837 lamExpr value pjs = case cons of

841 lamExpr value pjs = case cons of

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

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

843+ _ | sumEncoding opts == UntaggedValue

844+ -> parseUntaggedValue pjs cons value

845+ | otherwise

839− _ -> caseE (varE value) $

846+ -> caseE (varE value) $

840 if allNullaryToStringTag opts && all isNullary cons

847 if allNullaryToStringTag opts && all isNullary cons

841 then allNullaryMatches

848 then allNullaryMatches

842 else mixedMatches pjs

849 else mixedMatches pjs

@@ -878,6 +885,7 @@ consFromJSON jc tName opts cons = do

878 case sumEncoding opts of

885 case sumEncoding opts of

879 TaggedObject {tagFieldName, contentsFieldName} ->

886 TaggedObject {tagFieldName, contentsFieldName} ->

880 parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName

887 parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName

888+ UntaggedValue -> error "UntaggedValue: Should be handled already"

881 ObjectWithSingleField ->

889 ObjectWithSingleField ->

882 parseObject $ parseObjectWithSingleField pjs

890 parseObject $ parseObjectWithSingleField pjs

883 TwoElemArray ->

891 TwoElemArray ->

@@ -927,6 +935,27 @@ consFromJSON jc tName opts cons = do

927 , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

935 , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

928 ]

936 ]

929

937

938+ parseUntaggedValue pjs cons' conVal =

939+ foldr1 (\e e' -> infixApp e [|(<|>)|] e')

940+ (map (\x -> parseValue pjs x conVal) cons')

941+

942+ parseValue _pjs (NormalC conName []) conVal = do

943+ str <- newName "str"

944+ caseE (varE conVal)

945+ [ match (conP 'String [varP str])

946+ (guardedB

947+ [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)

948+ )

949+ ([|pure|] `appE` conE conName)

950+ ]

951+ )

952+ []

953+ , matchFailed tName conName "String"

954+ ]

955+ parseValue pjs con conVal =

956+ parseArgs jc pjs tName opts con (Right conVal)

957+

958+

930 parse2ElemArray pjs arr = do

959 parse2ElemArray pjs arr = do

931 conKey <- newName "conKey"

960 conKey <- newName "conKey"

932 conVal <- newName "conVal"

961 conVal <- newName "conVal"

Data/Aeson/Types/FromJSON.hs+48−9

@@ -774,17 +774,19 @@ class ParseSum arity f allNullary where

774 parseSum :: Options -> FromArgs arity a

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

776

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

777+instance ( SumFromString (a :+: b)

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

778+ , FromPair arity (a :+: b)

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

779+ , FromTaggedObject arity (a :+: b)

780+ , FromUntaggedValue arity (a :+: b)

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

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

781 parseSum opts fargs

782 parseSum opts fargs

782 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

783 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

783 | otherwise = Tagged . parseNonAllNullarySum opts fargs

784 | otherwise = Tagged . parseNonAllNullarySum opts fargs

784

785

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

786+instance ( FromPair arity (a :+: b)

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

787+ , FromTaggedObject arity (a :+: b)

788+ , FromUntaggedValue arity (a :+: b)

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

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

788 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

790 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

789

791

790--------------------------------------------------------------------------------

792--------------------------------------------------------------------------------

@@ -810,8 +812,9 @@ instance (Constructor c) => SumFromString (C1 c U1) where

810

812

811--------------------------------------------------------------------------------

813--------------------------------------------------------------------------------

812

814

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

815+parseNonAllNullarySum :: ( FromPair arity (a :+: b)

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

816+ , FromTaggedObject arity (a :+: b)

817+ , FromUntaggedValue arity (a :+: b)

815 ) => Options -> FromArgs arity c

818 ) => Options -> FromArgs arity c

816 -> Value -> Parser ((a :+: b) c)

819 -> Value -> Parser ((a :+: b) c)

817parseNonAllNullarySum opts fargs =

820parseNonAllNullarySum opts fargs =

@@ -838,6 +841,8 @@ parseNonAllNullarySum opts fargs =

838 _ -> fail "First element is not a String"

841 _ -> fail "First element is not a String"

839 else fail "Array doesn't have 2 elements"

842 else fail "Array doesn't have 2 elements"

840

843

844+ UntaggedValue -> parseUntaggedValue opts fargs

845+

841--------------------------------------------------------------------------------

846--------------------------------------------------------------------------------

842

847

843class FromTaggedObject arity f where

848class FromTaggedObject arity f where

@@ -1001,6 +1006,40 @@ instance ( Constructor c

1001

1006

1002--------------------------------------------------------------------------------

1007--------------------------------------------------------------------------------

1003

1008

1009+class FromUntaggedValue arity f where

1010+ parseUntaggedValue :: Options -> FromArgs arity a

1011+ -> Value -> Parser (f a)

1012+

1013+instance

1014+ ( FromUntaggedValue arity a

1015+ , FromUntaggedValue arity b

1016+ ) => FromUntaggedValue arity (a :+: b)

1017+ where

1018+ parseUntaggedValue opts fargs value =

1019+ L1 <$> parseUntaggedValue opts fargs value <|>

1020+ R1 <$> parseUntaggedValue opts fargs value

1021+

1022+instance OVERLAPPABLE_

1023+ ( GFromJSON arity a

1024+ , ConsFromJSON arity a

1025+ ) => FromUntaggedValue arity (C1 c a)

1026+ where

1027+ parseUntaggedValue = gParseJSON

1028+

1029+instance OVERLAPPING_

1030+ ( Constructor c )

1031+ => FromUntaggedValue arity (C1 c U1)

1032+ where

1033+ parseUntaggedValue opts _ (String s)

1034+ | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =

1035+ pure $ M1 U1

1036+ | otherwise =

1037+ fail $ "Invalid tag: " ++ unpack s

1038+ parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v

1039+

1040+

1041+--------------------------------------------------------------------------------

1042+

1004notFound :: Text -> Parser a

1043notFound :: Text -> Parser a

1005notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"

1044notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"

1006{-# INLINE notFound #-}

1045{-# INLINE notFound #-}

Data/Aeson/Types/Internal.hs+14

@@ -549,6 +549,20 @@ data SumEncoding =

549 -- by the encoded value of that field! If the constructor is not a

550 -- record the encoded constructor contents will be stored under

551 -- the 'contentsFieldName' field.

552+ | UntaggedValue

553+ -- ^ Constructor names won't be encoded. Instead only the contents of the

554+ -- constructor will be encoded as if the type had single constructor. JSON

555+ -- encodings have to be disjoint for decoding to work properly.

556+ --

557+ -- When decoding, constructors are tried in the order of definition. If some

558+ -- encodings overlap, the first one defined will succeed.

559+ --

560+ -- /Note:/ Nullary constructors are encoded as the string (using

561+ -- 'constructorTagModifier'). Having a nullary constructor alongside a

562+ -- single field constructor that encodes to a string leads to ambiguity.

563+ --

564+ -- /Note:/ Only the last error is kept when decoding, so in the case of

565+ -- mailformed JSON, only an error for the last constructor will be reported.

552 | ObjectWithSingleField

566 | ObjectWithSingleField

553 -- ^ A constructor will be encoded to an object with a single

567 -- ^ A constructor will be encoded to an object with a single

554 -- field named after the constructor tag (modified by the

568 -- field named after the constructor tag (modified by the

Data/Aeson/Types/ToJSON.hs+62

@@ -755,6 +755,7 @@ instance ( GetConName f

755 , TaggedObjectPairs arity f

756 , ObjectWithSingleFieldObj arity f

757 , TwoElemArrayObj arity f

758+ , UntaggedValueObj arity f

758 ) => SumToJSON arity f True where

759 ) => SumToJSON arity f True where

759 sumToJSON opts targs

760 sumToJSON opts targs

760 | allNullaryToStringTag opts = Tagged . String . pack

761 | allNullaryToStringTag opts = Tagged . String . pack

@@ -764,12 +765,14 @@ instance ( GetConName f

764instance ( TwoElemArrayObj arity f

765instance ( TwoElemArrayObj arity f

765 , TaggedObjectPairs arity f

766 , TaggedObjectPairs arity f

766 , ObjectWithSingleFieldObj arity f

767 , ObjectWithSingleFieldObj arity f

768+ , UntaggedValueObj arity f

767 ) => SumToJSON arity f False where

769 ) => SumToJSON arity f False where

768 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

770 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

769

771

770nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f

772nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f

771 , TaggedObjectPairs arity f

773 , TaggedObjectPairs arity f

772 , ObjectWithSingleFieldObj arity f

774 , ObjectWithSingleFieldObj arity f

775+ , UntaggedValueObj arity f

773 ) => Options -> ToArgs Value arity a

776 ) => Options -> ToArgs Value arity a

774 -> f a -> Value

777 -> f a -> Value

775nonAllNullarySumToJSON opts targs =

778nonAllNullarySumToJSON opts targs =

@@ -778,6 +781,7 @@ nonAllNullarySumToJSON opts targs =

778 object . taggedObjectPairs opts targs tagFieldName contentsFieldName

781 object . taggedObjectPairs opts targs tagFieldName contentsFieldName

779 ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs

782 ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs

780 TwoElemArray -> Array . twoElemArrayObj opts targs

783 TwoElemArray -> Array . twoElemArrayObj opts targs

784+ UntaggedValue -> untaggedValueObj opts targs

781

785

782--------------------------------------------------------------------------------

786--------------------------------------------------------------------------------

783

787

@@ -789,6 +793,7 @@ instance ( GetConName f

789 , TaggedObjectEnc arity f

793 , TaggedObjectEnc arity f

790 , ObjectWithSingleFieldEnc arity f

794 , ObjectWithSingleFieldEnc arity f

791 , TwoElemArrayEnc arity f

795 , TwoElemArrayEnc arity f

796+ , UntaggedValueEnc arity f

792 ) => SumToEncoding arity f True where

797 ) => SumToEncoding arity f True where

793 sumToEncoding opts targs

798 sumToEncoding opts targs

794 | allNullaryToStringTag opts = Tagged . toEncoding .

799 | allNullaryToStringTag opts = Tagged . toEncoding .

@@ -798,12 +803,14 @@ instance ( GetConName f

798instance ( TwoElemArrayEnc arity f

803instance ( TwoElemArrayEnc arity f

799 , TaggedObjectEnc arity f

804 , TaggedObjectEnc arity f

800 , ObjectWithSingleFieldEnc arity f

805 , ObjectWithSingleFieldEnc arity f

806+ , UntaggedValueEnc arity f

801 ) => SumToEncoding arity f False where

807 ) => SumToEncoding arity f False where

802 sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs

808 sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs

803

809

804nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f

810nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f

805 , TaggedObjectEnc arity f

811 , TaggedObjectEnc arity f

806 , ObjectWithSingleFieldEnc arity f

812 , ObjectWithSingleFieldEnc arity f

813+ , UntaggedValueEnc arity f

807 ) => Options -> ToArgs Encoding arity a

814 ) => Options -> ToArgs Encoding arity a

808 -> f a -> Encoding

815 -> f a -> Encoding

809nonAllNullarySumToEncoding opts targs =

816nonAllNullarySumToEncoding opts targs =

@@ -812,6 +819,7 @@ nonAllNullarySumToEncoding opts targs =

812 taggedObjectEnc opts targs tagFieldName contentsFieldName

819 taggedObjectEnc opts targs tagFieldName contentsFieldName

813 ObjectWithSingleField -> objectWithSingleFieldEnc opts targs

820 ObjectWithSingleField -> objectWithSingleFieldEnc opts targs

814 TwoElemArray -> twoElemArrayEnc opts targs

821 TwoElemArray -> twoElemArrayEnc opts targs

822+ UntaggedValue -> untaggedValueEnc opts targs

815

823

816--------------------------------------------------------------------------------

824--------------------------------------------------------------------------------

817

825

@@ -1172,6 +1180,60 @@ instance ( GToEncoding arity a

1172 gToEncoding opts targs v ><

1180 gToEncoding opts targs v ><

1173 E.closeCurly

1181 E.closeCurly

1174

1182

1183+--------------------------------------------------------------------------------

1184+

1185+class UntaggedValueObj arity f where

1186+ untaggedValueObj :: Options -> ToArgs Value arity a

1187+ -> f a -> Value

1188+

1189+instance

1190+ ( UntaggedValueObj arity a

1191+ , UntaggedValueObj arity b

1192+ ) => UntaggedValueObj arity (a :+: b)

1193+ where

1194+ untaggedValueObj opts targs (L1 x) = untaggedValueObj opts targs x

1195+ untaggedValueObj opts targs (R1 x) = untaggedValueObj opts targs x

1196+

1197+instance OVERLAPPABLE_

1198+ ( GToJSON arity a

1199+ , ConsToJSON arity a

1200+ ) => UntaggedValueObj arity (C1 c a) where

1201+ untaggedValueObj = gToJSON

1202+

1203+instance OVERLAPPING_

1204+ ( Constructor c )

1205+ => UntaggedValueObj arity (C1 c U1)

1206+ where

1207+ untaggedValueObj opts _ _ = toJSON $

1208+ constructorTagModifier opts $ conName (undefined :: t c U1 p)

1209+

1210+--------------------------------------------------------------------------------

1211+

1212+class UntaggedValueEnc arity f where

1213+ untaggedValueEnc :: Options -> ToArgs Encoding arity a

1214+ -> f a -> Encoding

1215+instance

1216+ ( UntaggedValueEnc arity a

1217+ , UntaggedValueEnc arity b

1218+ ) => UntaggedValueEnc arity (a :+: b)

1219+ where

1220+ untaggedValueEnc opts targs (L1 x) = untaggedValueEnc opts targs x

1221+ untaggedValueEnc opts targs (R1 x) = untaggedValueEnc opts targs x

1222+

1223+instance OVERLAPPABLE_

1224+ ( GToEncoding arity a

1225+ , ConsToEncoding arity a

1226+ ) => UntaggedValueEnc arity (C1 c a)

1227+ where

1228+ untaggedValueEnc = gToEncoding

1229+

1230+instance OVERLAPPING_

1231+ ( Constructor c )

1232+ => UntaggedValueEnc arity (C1 c U1)

1233+ where

1234+ untaggedValueEnc opts _ _ = toEncoding $

1235+ constructorTagModifier opts $ conName (undefined :: t c U1 p)

1236+

1175-------------------------------------------------------------------------------

1237-------------------------------------------------------------------------------

1176-- Instances

1238-- Instances

1177-------------------------------------------------------------------------------

1239-------------------------------------------------------------------------------

changelog.md+2

@@ -16,6 +16,8 @@ For the latest version of this document, please see [https://github.com/bos/aeso

17* Added `Data.Aeson.Encoding` with functions to work with `Encoding` in an abstract way.

19+* Added `UntaggedValue` to `SumEncoding`

20+

19* Export `decodeWith`, `decodeStrictWith`, `eitherDecodeWith`, and

21* Export `decodeWith`, `decodeStrictWith`, `eitherDecodeWith`, and

20 `eitherDecodeStrictWith` from `Data.Aeson.Parser`. This allows

22 `eitherDecodeStrictWith` from `Data.Aeson.Parser`. This allows

21 decoding using explicit parsers instead of using `FromJSON`

23 decoding using explicit parsers instead of using `FromJSON`

tests/Encoders.hs+22

@@ -232,6 +232,28 @@ gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields

232gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding

233gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

234

235+-------------------------------------------------------------------------------

236+-- EitherTextInt encoders/decodes

237+-------------------------------------------------------------------------------

238+

239+thEitherTextIntToJSONUntaggedValue :: EitherTextInt -> Value

240+thEitherTextIntToJSONUntaggedValue = $(mkToJSON optsUntaggedValue ''EitherTextInt)

241+

242+thEitherTextIntToEncodingUntaggedValue :: EitherTextInt -> Encoding

243+thEitherTextIntToEncodingUntaggedValue = $(mkToEncoding optsUntaggedValue ''EitherTextInt)

244+

245+thEitherTextIntParseJSONUntaggedValue :: Value -> Parser EitherTextInt

246+thEitherTextIntParseJSONUntaggedValue = $(mkParseJSON optsUntaggedValue ''EitherTextInt)

247+

248+

249+gEitherTextIntToJSONUntaggedValue :: EitherTextInt -> Value

250+gEitherTextIntToJSONUntaggedValue = genericToJSON optsUntaggedValue

251+

252+gEitherTextIntToEncodingUntaggedValue :: EitherTextInt -> Encoding

253+gEitherTextIntToEncodingUntaggedValue = genericToEncoding optsUntaggedValue

254+

255+gEitherTextIntParseJSONUntaggedValue :: Value -> Parser EitherTextInt

256+gEitherTextIntParseJSONUntaggedValue = genericParseJSON optsUntaggedValue

235

257

236--------------------------------------------------------------------------------

258--------------------------------------------------------------------------------

237-- Approx encoders/decoders

259-- Approx encoders/decoders

tests/Instances.hs+8

@@ -155,6 +155,14 @@ instance Arbitrary a => Arbitrary (SomeType a) where

155 , Record <$> arbitrary <*> arbitrary <*> arbitrary

156 ]

157

158+instance Arbitrary EitherTextInt where

159+ arbitrary = oneof

160+ [ LeftBool <$> arbitrary

161+ , RightInt <$> arbitrary

162+ , BothTextInt <$> arbitrary <*> arbitrary

163+ , pure NoneNullary

164+ ]

165+

158instance Arbitrary (GADT String) where

166instance Arbitrary (GADT String) where

159 arbitrary = GADT <$> arbitrary

167 arbitrary = GADT <$> arbitrary

160

168

tests/Options.hs+5

@@ -34,3 +34,8 @@ optsOmitNothingFields :: Options

34optsOmitNothingFields = optsDefault

35 { omitNothingFields = True

36 }

37+

38+optsUntaggedValue :: Options

39+optsUntaggedValue = optsDefault

40+ { sumEncoding = UntaggedValue

41+ }

tests/Properties.hs+24

@@ -172,6 +172,16 @@ isObjectWithSingleField :: Value -> Bool

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

173isObjectWithSingleField _ = False

174

175+-- | is untaggedValue of EitherTextInt

176+isUntaggedValueETI :: Value -> Bool

177+isUntaggedValueETI (String s)

178+ | s == "nonenullary" = True

179+isUntaggedValueETI (Bool _) = True

180+isUntaggedValueETI (Number _) = True

181+isUntaggedValueETI (Array a) = length a == 2

182+isUntaggedValueETI _ = False

183+

184+

175--------------------------------------------------------------------------------

185--------------------------------------------------------------------------------

176

186

177

187

@@ -293,6 +303,10 @@ tests = testGroup "properties" [

293 , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

303 , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

294 ]

304 ]

295 ]

305 ]

306+ , testGroup "EitherTextInt" [

307+ testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)

308+ , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)

309+ ]

296 , testGroup "SomeType" [

310 , testGroup "SomeType" [

297 testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)

311 testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)

298 , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)

312 , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)

@@ -325,6 +339,9 @@ tests = testGroup "properties" [

325 , testProperty "ApproxDefault" $

339 , testProperty "ApproxDefault" $

326 gApproxToJSONDefault `sameAs` gApproxToEncodingDefault

340 gApproxToJSONDefault `sameAs` gApproxToEncodingDefault

327

341

342+ , testProperty "EitherTextInt UntaggedValue" $

343+ gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue

344+

328 , testProperty "SomeType2ElemArray" $

345 , testProperty "SomeType2ElemArray" $

329 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

346 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

330#if __GLASGOW_HASKELL__ >= 706

347#if __GLASGOW_HASKELL__ >= 706

@@ -371,6 +388,10 @@ tests = testGroup "properties" [

371 , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)

388 , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)

372 ]

389 ]

373 ]

390 ]

391+ , testGroup "EitherTextInt" [

392+ testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)

393+ , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)

394+ ]

374 , testGroup "SomeType" [

395 , testGroup "SomeType" [

375 testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)

396 testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)

376 , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)

397 , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)

@@ -418,6 +439,9 @@ tests = testGroup "properties" [

418 , testProperty "ApproxDefault" $

439 , testProperty "ApproxDefault" $

419 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault

440 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault

420

441

442+ , testProperty "EitherTextInt UntaggedValue" $

443+ thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue

444+

421 , testProperty "SomeType2ElemArray" $

445 , testProperty "SomeType2ElemArray" $

422 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray

446 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray

423 , testProperty "SomeType2ElemArray unary" $

447 , testProperty "SomeType2ElemArray unary" $

tests/Types.hs+9

@@ -65,6 +65,14 @@ data SomeType a = Nullary

65 , testThree :: Maybe a

66 } deriving (Eq, Show)

68+-- Used for testing UntaggedValue SumEncoding

69+data EitherTextInt

70+ = LeftBool Bool

71+ | RightInt Int

72+ | BothTextInt Text Int

73+ | NoneNullary

74+ deriving (Eq, Show)

75+

68data GADT a where

76data GADT a where

69 GADT :: { gadt :: String } -> GADT String

77 GADT :: { gadt :: String } -> GADT String

70 deriving Typeable

78 deriving Typeable

@@ -85,6 +93,7 @@ deriving instance Generic (SomeType a)

85#if __GLASGOW_HASKELL__ >= 706

93#if __GLASGOW_HASKELL__ >= 706

86deriving instance Generic1 SomeType

94deriving instance Generic1 SomeType

87#endif

95#endif

96+deriving instance Generic EitherTextInt

89failure :: Show a => String -> String -> a -> Property

98failure :: Show a => String -> String -> a -> Property

90failure func msg v = counterexample

99failure func msg v = counterexample

tests/UnitTests.hs+17−2

@@ -15,11 +15,11 @@ import Instances ()

16import Control.Applicative (Const(..))

17import Control.Monad (forM)

18−import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))

18+import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericParseJSON, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))

19import Data.Aeson.Text (encodeToTextBuilder)

20import Data.Aeson.Internal (JSONPathElement(..), formatError)

21import Data.Aeson.TH (deriveJSON)

22−import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)

22+import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields, Options(..), SumEncoding(..))

23import Data.Char (toUpper)

24import Data.Hashable (hash)

25import Data.List.NonEmpty (NonEmpty(..))

@@ -108,6 +108,18 @@ camelFrom c s = let (p:ps) = split c s

108 split c' s' = map L.unpack $ L.split c' $ L.pack s'

109 capitalize t = toUpper (head t) : tail t

110

111+

112+data MyEither a b = MyLeft a | MyRight b

113+ deriving (Generic, Show, Eq)

114+

115+instance (ToJSON a, ToJSON b) => ToJSON (MyEither a b) where

116+ toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

117+ toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue }

118+

119+instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where

120+ parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

121+

122+

111data Wibble = Wibble {

123data Wibble = Wibble {

112 wibbleString :: String

124 wibbleString :: String

113 , wibbleInt :: Int

125 , wibbleInt :: Int

@@ -395,6 +407,9 @@ jsonExamples =

395 , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)

407 , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)

396 , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)

408 , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)

397 , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)

409 , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)

410+

411+ , Example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String)

412+ , Example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String)

398 ]

413 ]

399

414

400

415