2733775 · typeable/aeson

.travis.yml+1−1

@@ -34,7 +34,7 @@ matrix:

3434 - env: BUILD=cabal CABALVER=1.24 GHCVER=8.0.1

3535 compiler: ": #GHC 8.0.1"

3636 addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}

37− - env: BUILD=stack CABALVER=1.22 GHCVER=7.10.3

37+ - env: BUILD=stack CABALVER=1.22 GHCVER=7.10.3 STACK_YAML=stack-bench.yaml

3838 compiler: ": #GHC 7.10.3"

3939 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}

4040

Data/Aeson/TH.hs+33−4

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

112112 , mkLiftParseJSON2

113113 ) where

114114

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

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

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

117117 , ToJSON(..), FromJSON(..)

118118 , ToJSON1(..), FromJSON1(..)

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

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

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

439439 ]

440−

440+ UntaggedValue -> exp

441441 | otherwise = exp

442442

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

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

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

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

449449 ]

450+ UntaggedValue -> conStr opts conName

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

451452

452453-- | 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

545546 ObjectWithSingleField ->

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

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

549+ UntaggedValue -> exp

548550 else exp

549551 ) []

550552

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

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

611613 ObjectWithSingleField ->

612614 object (encStr opts conName <:> fexp)

613−

615+ UntaggedValue -> exp

614616 | otherwise = exp

615617

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

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

619621 TaggedObject{tagFieldName} ->

620622 object $

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

624+ UntaggedValue -> encStr opts conName

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

623626

624627-- | 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

706709 objBody

707710 ObjectWithSingleField -> object $

708711 encStr opts conName <:> exp

712+ UntaggedValue -> exp

709713 else exp

710714 ) []

711715

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

836840 where

837841 lamExpr value pjs = case cons of

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

839− _ -> caseE (varE value) $

843+ _ | sumEncoding opts == UntaggedValue

844+ -> parseUntaggedValue pjs cons value

845+ | otherwise

846+ -> caseE (varE value) $

840847 if allNullaryToStringTag opts && all isNullary cons

841848 then allNullaryMatches

842849 else mixedMatches pjs

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

878885 case sumEncoding opts of

879886 TaggedObject {tagFieldName, contentsFieldName} ->

880887 parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName

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

881889 ObjectWithSingleField ->

882890 parseObject $ parseObjectWithSingleField pjs

883891 TwoElemArray ->

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

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

928936 ]

929937

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+

930959 parse2ElemArray pjs arr = do

931960 conKey <- newName "conKey"

932961 conVal <- newName "conVal"

Data/Aeson/Types/FromJSON.hs+51−12

@@ -660,9 +660,9 @@ obj .: key = case H.lookup key obj of

660660 Just v -> parseJSON v <?> Key key

661661{-# INLINE (.:) #-}

662662

663−-- | Retrieve the value associated with the given key of an 'Object'.

664−-- The result is 'Nothing' if the key is not present, or 'empty' if

665−-- the value cannot be converted to the desired type.

663+-- | Retrieve the value associated with the given key of an 'Object'. The

664+-- result is 'Nothing' if the key is not present or value is 'Null', or 'empty'

665+-- if the value cannot be converted to the desired type.

666666--

667667-- This accessor is most useful if the key and value can be absent

668668-- from an object without affecting its validity. If the key and

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

774774 parseSum :: Options -> FromArgs arity a

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

776776

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

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

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

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

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

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

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

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

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

781782 parseSum opts fargs

782783 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

783784 | otherwise = Tagged . parseNonAllNullarySum opts fargs

784785

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

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

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

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

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

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

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

788790 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

789791

790792--------------------------------------------------------------------------------

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

810812

811813--------------------------------------------------------------------------------

812814

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

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

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

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

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

815818 ) => Options -> FromArgs arity c

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

817820parseNonAllNullarySum opts fargs =

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

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

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

840843

844+ UntaggedValue -> parseUntaggedValue opts fargs

845+

841846--------------------------------------------------------------------------------

842847

843848class FromTaggedObject arity f where

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

10011006

10021007--------------------------------------------------------------------------------

10031008

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+

10041043notFound :: Text -> Parser a

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

10061045{-# INLINE notFound #-}

Data/Aeson/Types/Generic.hs+2

@@ -47,6 +47,7 @@ instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False

4747instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord

4848instance IsRecord (K1 i c) True

4949instance IsRecord Par1 True

50+instance IsRecord (Rec1 f) True

5051instance IsRecord (f :.: g) True

5152instance IsRecord U1 False

5253 where isUnary = const False

@@ -64,6 +65,7 @@ instance AllNullary (a :*: b) False

6465instance AllNullary (a :.: b) False

6566instance AllNullary (K1 i c) False

6667instance AllNullary Par1 False

68+instance AllNullary (Rec1 f) False

6769instance AllNullary U1 True

6870

6971newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

Data/Aeson/Types/Internal.hs+14

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

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

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

551551 -- 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.

552566 | ObjectWithSingleField

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

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

Data/Aeson/Types/ToJSON.hs+64−2

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

755755 , TaggedObjectPairs arity f

756756 , ObjectWithSingleFieldObj arity f

757757 , TwoElemArrayObj arity f

758+ , UntaggedValueObj arity f

758759 ) => SumToJSON arity f True where

759760 sumToJSON opts targs

760761 | allNullaryToStringTag opts = Tagged . String . pack

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

764765instance ( TwoElemArrayObj arity f

765766 , TaggedObjectPairs arity f

766767 , ObjectWithSingleFieldObj arity f

768+ , UntaggedValueObj arity f

767769 ) => SumToJSON arity f False where

768770 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

769771

770772nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f

771773 , TaggedObjectPairs arity f

772774 , ObjectWithSingleFieldObj arity f

775+ , UntaggedValueObj arity f

773776 ) => Options -> ToArgs Value arity a

774777 -> f a -> Value

775778nonAllNullarySumToJSON opts targs =

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

778781 object . taggedObjectPairs opts targs tagFieldName contentsFieldName

779782 ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs

780783 TwoElemArray -> Array . twoElemArrayObj opts targs

784+ UntaggedValue -> untaggedValueObj opts targs

781785

782786--------------------------------------------------------------------------------

783787

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

789793 , TaggedObjectEnc arity f

790794 , ObjectWithSingleFieldEnc arity f

791795 , TwoElemArrayEnc arity f

796+ , UntaggedValueEnc arity f

792797 ) => SumToEncoding arity f True where

793798 sumToEncoding opts targs

794799 | allNullaryToStringTag opts = Tagged . toEncoding .

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

798803instance ( TwoElemArrayEnc arity f

799804 , TaggedObjectEnc arity f

800805 , ObjectWithSingleFieldEnc arity f

806+ , UntaggedValueEnc arity f

801807 ) => SumToEncoding arity f False where

802808 sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs

803809

804810nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f

805811 , TaggedObjectEnc arity f

806812 , ObjectWithSingleFieldEnc arity f

813+ , UntaggedValueEnc arity f

807814 ) => Options -> ToArgs Encoding arity a

808815 -> f a -> Encoding

809816nonAllNullarySumToEncoding opts targs =

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

812819 taggedObjectEnc opts targs tagFieldName contentsFieldName

813820 ObjectWithSingleField -> objectWithSingleFieldEnc opts targs

814821 TwoElemArray -> twoElemArrayEnc opts targs

822+ UntaggedValue -> untaggedValueEnc opts targs

815823

816824--------------------------------------------------------------------------------

817825

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

11721180 gToEncoding opts targs v ><

11731181 E.closeCurly

11741182

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+

11751237-------------------------------------------------------------------------------

11761238-- Instances

11771239-------------------------------------------------------------------------------

@@ -1808,10 +1870,10 @@ instance ToJSON1 Vector where

18081870 {-# INLINE liftToEncoding #-}

18091871

18101872instance (ToJSON a) => ToJSON (Vector a) where

1811− toJSON = Array . V.map toJSON

1873+ toJSON = toJSON1

18121874 {-# INLINE toJSON #-}

18131875

1814− toEncoding = encodeVector

1876+ toEncoding = toEncoding1

18151877 {-# INLINE toEncoding #-}

18161878

18171879encodeVector :: (ToJSON a, VG.Vector v a) => v a -> Encoding

benchmarks/AesonFoldable.hs+49−20

@@ -1,6 +1,9 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings, PackageImports #-}

22import Criterion.Main

3−import Data.Aeson

3+

4+import qualified "aeson" Data.Aeson as A

5+import qualified "aeson-benchmarks" Data.Aeson as B

6+

47import Data.Foldable (toList)

58

69import qualified Data.Sequence as S

@@ -13,9 +16,13 @@ import qualified Data.Vector.Unboxed as U

1316

1417newtype L f = L { getL :: f Int }

1518

16−instance Foldable f => ToJSON (L f) where

19+instance Foldable f => B.ToJSON (L f) where

1720 toJSON = error "do not use this"

18− toEncoding = toEncoding . toList . getL

21+ toEncoding = B.toEncoding . toList . getL

22+

23+instance Foldable f => A.ToJSON (L f) where

24+ toJSON = error "do not use this"

25+ toEncoding = A.toEncoding . toList . getL

1926

2027-------------------------------------------------------------------------------

2128-- Foldable

@@ -23,9 +30,13 @@ instance Foldable f => ToJSON (L f) where

2330

2431newtype F f = F { getF :: f Int }

2532

26−instance Foldable f => ToJSON (F f) where

33+instance Foldable f => B.ToJSON (F f) where

34+ toJSON = error "do not use this"

35+ toEncoding = B.foldable . getF

36+

37+instance Foldable f => A.ToJSON (F f) where

2738 toJSON = error "do not use this"

28− toEncoding = foldable . getF

39+ toEncoding = A.foldable . getF

2940

3041-------------------------------------------------------------------------------

3142-- Values

@@ -47,34 +58,52 @@ valueUVector = U.fromList valueList

4758-- Main

4859-------------------------------------------------------------------------------

4960

50−benchEncode

51− :: ToJSON a

61+benchEncodeA

62+ :: A.ToJSON a

63+ => String

64+ -> a

65+ -> Benchmark

66+benchEncodeA name val

67+ = bench ("A " ++ name) $ nf A.encode val

68+

69+benchEncodeB

70+ :: B.ToJSON a

5271 => String

5372 -> a

5473 -> Benchmark

55−benchEncode name val

56− = bench name $ nf encode val

74+benchEncodeB name val

75+ = bench ("B " ++ name) $ nf B.encode val

5776

5877main :: IO ()

5978main = defaultMain

6079 [ bgroup "encode"

6180 [ bgroup "List"

62− [ benchEncode "-" valueList

63− , benchEncode "L" $ L valueList

64− , benchEncode "F" $ F valueList

81+ [ benchEncodeB "-" valueList

82+ , benchEncodeB "L" $ L valueList

83+ , benchEncodeB "F" $ F valueList

84+ , benchEncodeA "-" valueList

85+ , benchEncodeA "L" $ L valueList

86+ , benchEncodeA "F" $ F valueList

6587 ]

6688 , bgroup "Seq"

67− [ benchEncode "-" valueSeq

68− , benchEncode "L" $ L valueSeq

69− , benchEncode "F" $ F valueSeq

89+ [ benchEncodeB "-" valueSeq

90+ , benchEncodeB "L" $ L valueSeq

91+ , benchEncodeB "F" $ F valueSeq

92+ , benchEncodeA "-" valueSeq

93+ , benchEncodeA "L" $ L valueSeq

94+ , benchEncodeA "F" $ F valueSeq

7095 ]

7196 , bgroup "Vector"

72− [ benchEncode "-" valueVector

73− , benchEncode "L" $ L valueVector

74− , benchEncode "F" $ F valueVector

97+ [ benchEncodeB "-" valueVector

98+ , benchEncodeB "L" $ L valueVector

99+ , benchEncodeB "F" $ F valueVector

100+ , benchEncodeA "-" valueVector

101+ , benchEncodeA "L" $ L valueVector

102+ , benchEncodeA "F" $ F valueVector

75103 ]

76104 , bgroup "Vector.Unboxed"

77− [ benchEncode "-" valueUVector

105+ [ benchEncodeB "-" valueUVector

106+ , benchEncodeA "-" valueUVector

78107 ]

79108 ]

80109 ]

benchmarks/AesonMap.hs+59−39

@@ -1,9 +1,7 @@

1−{-# LANGUAGE OverloadedStrings, RankNTypes #-}

1+{-# LANGUAGE OverloadedStrings, RankNTypes, PackageImports, FlexibleContexts #-}

22

33import Control.DeepSeq

44import Criterion.Main

5−import Data.Aeson

6−import Data.Aeson.Types (fromJSONKeyCoerce)

75import Data.Hashable

86import Data.Proxy (Proxy (..))

97import Data.Tagged (Tagged (..))

@@ -12,6 +10,11 @@ import qualified Data.Text as T

1210import qualified Data.Map as M

1311import qualified Data.HashMap.Strict as HM

1412

13+import qualified "aeson" Data.Aeson as A

14+

15+import qualified "aeson-benchmarks" Data.Aeson as B

16+import qualified "aeson-benchmarks" Data.Aeson.Types as B (fromJSONKeyCoerce)

17+

1518value :: Int -> HM.HashMap T.Text T.Text

1619value n = HM.fromList $ map f [1..n]

1720 where

@@ -35,10 +38,11 @@ instance NFData T1 where

3538 rnf (T1 t) = rnf t

3639instance Hashable T1 where

3740 hashWithSalt salt (T1 t) = hashWithSalt salt t

38−instance FromJSON T1 where

39− parseJSON = withText "T1" $ pure . T1

40−instance FromJSONKey T1 where

41− fromJSONKey = FromJSONKeyText T1

41+

42+instance B.FromJSON T1 where

43+ parseJSON = B.withText "T1" $ pure . T1

44+instance B.FromJSONKey T1 where

45+ fromJSONKey = B.FromJSONKeyText T1

4246

4347-------------------------------------------------------------------------------

4448-- Coerce

@@ -51,10 +55,11 @@ instance NFData T2 where

5155 rnf (T2 t) = rnf t

5256instance Hashable T2 where

5357 hashWithSalt salt (T2 t) = hashWithSalt salt t

54−instance FromJSON T2 where

55− parseJSON = withText "T2" $ pure . T2

56−instance FromJSONKey T2 where

57− fromJSONKey = fromJSONKeyCoerce

58+

59+instance B.FromJSON T2 where

60+ parseJSON = B.withText "T2" $ pure . T2

61+instance B.FromJSONKey T2 where

62+ fromJSONKey = B.fromJSONKeyCoerce

5863

5964-------------------------------------------------------------------------------

6065-- TextParser

@@ -67,10 +72,11 @@ instance NFData T3 where

6772 rnf (T3 t) = rnf t

6873instance Hashable T3 where

6974 hashWithSalt salt (T3 t) = hashWithSalt salt t

70−instance FromJSON T3 where

71− parseJSON = withText "T3" $ pure . T3

72−instance FromJSONKey T3 where

73− fromJSONKey = FromJSONKeyTextParser (pure . T3)

75+

76+instance B.FromJSON T3 where

77+ parseJSON = B.withText "T3" $ pure . T3

78+instance B.FromJSONKey T3 where

79+ fromJSONKey = B.FromJSONKeyTextParser (pure . T3)

7480

7581-------------------------------------------------------------------------------

7682-- Values

@@ -83,30 +89,40 @@ value1000 = value 1000

8389value10000 = value 10000

8490

8591encodedValue10 :: LBS.ByteString

86−encodedValue10 = encode $ value10

92+encodedValue10 = B.encode $ value10

8793

8894encodedValue100 :: LBS.ByteString

89−encodedValue100 = encode $ value100

95+encodedValue100 = B.encode $ value100

9096

9197encodedValue1000 :: LBS.ByteString

92−encodedValue1000 = encode $ value1000

98+encodedValue1000 = B.encode $ value1000

9399

94100encodedValue10000 :: LBS.ByteString

95−encodedValue10000 = encode $ value10000

101+encodedValue10000 = B.encode $ value10000

96102

97103-------------------------------------------------------------------------------

98104-- Helpers

99105-------------------------------------------------------------------------------

100106

101−decodeHM

102− :: (FromJSONKey k, Eq k, Hashable k)

107+decodeHMB

108+ :: (B.FromJSONKey k, Eq k, Hashable k)

103109 => Proxy k -> LBS.ByteString -> Maybe (HM.HashMap k T.Text)

104−decodeHM _ = decode

110+decodeHMB _ = B.decode

111+

112+decodeHMA

113+ :: (A.FromJSON (HM.HashMap k T.Text), Eq k, Hashable k)

114+ => Proxy k -> LBS.ByteString -> Maybe (HM.HashMap k T.Text)

115+decodeHMA _ = A.decode

116+

117+decodeMapB

118+ :: (B.FromJSONKey k, Ord k)

119+ => Proxy k -> LBS.ByteString -> Maybe (M.Map k T.Text)

120+decodeMapB _ = B.decode

105121

106−decodeMap

107− :: (FromJSONKey k, Ord k)

122+decodeMapA

123+ :: (A.FromJSON (M.Map k T.Text), Ord k)

108124 => Proxy k -> LBS.ByteString -> Maybe (M.Map k T.Text)

109−decodeMap _ = decode

125+decodeMapA _ = A.decode

110126

111127proxyText :: Proxy T.Text

112128proxyText = Proxy

@@ -132,14 +148,15 @@ benchDecodeHM

132148 -> LBS.ByteString

133149 -> Benchmark

134150benchDecodeHM name val = bgroup name

135− [ bench "Text" $ nf (decodeHM proxyText) val

136− , bench "Identity" $ nf (decodeHM proxyT1) val

137− , bench "Coerce" $ nf (decodeHM proxyT2) val

138− , bench "Parser" $ nf (decodeHM proxyT3) val

139− , bench "Tagged Text" $ nf (decodeHM $ proxyTagged proxyText) val

140− , bench "Tagged Identity" $ nf (decodeHM $ proxyTagged proxyT1) val

141− , bench "Tagged Coerce" $ nf (decodeHM $ proxyTagged proxyT2) val

142− , bench "Tagged Parser" $ nf (decodeHM $ proxyTagged proxyT3) val

151+ [ bench "Text" $ nf (decodeHMB proxyText) val

152+ , bench "Identity" $ nf (decodeHMB proxyT1) val

153+ , bench "Coerce" $ nf (decodeHMB proxyT2) val

154+ , bench "Parser" $ nf (decodeHMB proxyT3) val

155+ , bench "aeson-0.11" $ nf (decodeHMA proxyText) val

156+ , bench "Tagged Text" $ nf (decodeHMB $ proxyTagged proxyText) val

157+ , bench "Tagged Identity" $ nf (decodeHMB $ proxyTagged proxyT1) val

158+ , bench "Tagged Coerce" $ nf (decodeHMB $ proxyTagged proxyT2) val

159+ , bench "Tagged Parser" $ nf (decodeHMB $ proxyTagged proxyT3) val

143160 ]

144161

145162benchDecodeMap

@@ -147,10 +164,11 @@ benchDecodeMap

147164 -> LBS.ByteString

148165 -> Benchmark

149166benchDecodeMap name val = bgroup name

150− [ bench "Text" $ nf (decodeMap proxyText) val

151− , bench "Identity" $ nf (decodeMap proxyT1) val

152− , bench "Coerce" $ nf (decodeMap proxyT2) val

153− , bench "Parser" $ nf (decodeMap proxyT3) val

167+ [ bench "Text" $ nf (decodeMapB proxyText) val

168+ , bench "Identity" $ nf (decodeMapB proxyT1) val

169+ , bench "Coerce" $ nf (decodeMapB proxyT2) val

170+ , bench "Parser" $ nf (decodeMapB proxyT3) val

171+ , bench "aeson-0.11" $ nf (decodeMapA proxyText) val

154172 ]

155173

156174benchEncodeHM

@@ -158,7 +176,8 @@ benchEncodeHM

158176 -> HM.HashMap T.Text T.Text

159177 -> Benchmark

160178benchEncodeHM name val = bgroup name

161− [ bench "Text" $ nf encode val

179+ [ bench "Text" $ nf B.encode val

180+ , bench "aeson-0.11" $ nf A.encode val

162181 ]

163182

164183benchEncodeMap

@@ -166,7 +185,8 @@ benchEncodeMap

166185 -> HM.HashMap T.Text T.Text

167186 -> Benchmark

168187benchEncodeMap name val = bgroup name

169− [ bench "Text" $ nf encode val'

188+ [ bench "Text" $ nf B.encode val'

189+ , bench "aeson-0.11" $ nf A.encode val'

170190 ]

171191 where

172192 val' :: M.Map T.Text T.Text

benchmarks/AesonParse.hs+2−1

@@ -1,8 +1,9 @@

11{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2+{-# LANGUAGE PackageImports #-}

23

34import Control.Exception

45import Control.Monad

5−import Data.Aeson

6+import "aeson-benchmarks" Data.Aeson

67import Data.Attoparsec.ByteString (IResult(..), parseWith)

78import Data.Time.Clock

89import System.Environment (getArgs)

benchmarks/Compare.hs+2−1

@@ -1,4 +1,5 @@

11{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE PackageImports #-}

23

34module Main (main) where

45

@@ -11,7 +12,7 @@ import Twitter

1112import Twitter.Manual ()

1213import Typed.Common

1314import qualified Compare.JsonBench as JsonBench

14−import qualified Data.Aeson as Aeson

15+import qualified "aeson-benchmarks" Data.Aeson as Aeson

1516

1617main :: IO ()

1718main =

benchmarks/Typed/Common.hs+7

@@ -1,6 +1,13 @@

1+{-# LANGUAGE CPP, PackageImports #-}

12module Typed.Common (load) where

23

4+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

35import Data.Aeson hiding (Result)

6+#else

7+import "aeson" Data.Aeson hiding (Result)

8+import qualified "aeson-benchmarks" Data.Aeson as B

9+#endif

10+

411import Data.ByteString.Lazy as L

512import Control.Applicative

613import System.IO

benchmarks/Typed/Generic.hs+22−10

@@ -1,29 +1,41 @@

1+{-# LANGUAGE PackageImports #-}

12module Typed.Generic (benchmarks) where

23

4+import "aeson" Data.Aeson hiding (Result)

5+import qualified "aeson-benchmarks" Data.Aeson as B

6+

37import Control.Applicative

48import Criterion

5−import Data.Aeson hiding (Result)

6−import Data.ByteString.Builder as B

79import Data.ByteString.Lazy as L

810import Twitter.TH

911import Typed.Common

1012

11−encodeDirect :: Result -> L.ByteString

12−encodeDirect = encode

13+encodeDirectA :: Result -> L.ByteString

14+encodeDirectA = encode

15+

16+encodeViaValueA :: Result -> L.ByteString

17+encodeViaValueA = encode . toJSON

18+

19+encodeDirectB :: Result -> L.ByteString

20+encodeDirectB = B.encode

1321

14−encodeViaValue :: Result -> L.ByteString

15−encodeViaValue = encode . toJSON

22+encodeViaValueB :: Result -> L.ByteString

23+encodeViaValueB = B.encode . B.toJSON

1624

1725benchmarks :: Benchmark

1826benchmarks =

1927 env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

2028 bgroup "generic" [

2129 bgroup "direct" [

22− bench "twitter100" $ nf encodeDirect twitter100

23− , bench "jp100" $ nf encodeDirect jp100

30+ bench "twitter100" $ nf encodeDirectB twitter100

31+ , bench "jp100" $ nf encodeDirectB jp100

32+ , bench "twitter100 baseline" $ nf encodeDirectA twitter100

33+ , bench "jp100 baseline" $ nf encodeDirectA jp100

2434 ]

2535 , bgroup "viaValue" [

26− bench "twitter100" $ nf encodeViaValue twitter100

27− , bench "jp100" $ nf encodeViaValue jp100

36+ bench "twitter100" $ nf encodeViaValueB twitter100

37+ , bench "jp100" $ nf encodeViaValueB jp100

38+ , bench "twitter100 baseline" $ nf encodeViaValueA twitter100

39+ , bench "jp100 baseline" $ nf encodeViaValueA jp100

2840 ]

2941 ]

benchmarks/Typed/Manual.hs+22−10

@@ -1,29 +1,41 @@

1+{-# LANGUAGE PackageImports #-}

12module Typed.Manual (benchmarks) where

23

4+import "aeson" Data.Aeson hiding (Result)

5+import qualified "aeson-benchmarks" Data.Aeson as B

6+

37import Control.Applicative

48import Criterion

5−import Data.Aeson hiding (Result)

6−import Data.ByteString.Builder as B

79import Data.ByteString.Lazy as L

810import Twitter.Manual

911import Typed.Common

1012

11−encodeDirect :: Result -> L.ByteString

12−encodeDirect = encode

13+encodeDirectA :: Result -> L.ByteString

14+encodeDirectA = encode

15+

16+encodeViaValueA :: Result -> L.ByteString

17+encodeViaValueA = encode . toJSON

18+

19+encodeDirectB :: Result -> L.ByteString

20+encodeDirectB = B.encode

1321

14−encodeViaValue :: Result -> L.ByteString

15−encodeViaValue = encode . toJSON

22+encodeViaValueB :: Result -> L.ByteString

23+encodeViaValueB = B.encode . B.toJSON

1624

1725benchmarks :: Benchmark

1826benchmarks =

1927 env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

2028 bgroup "manual" [

2129 bgroup "direct" [

22− bench "twitter100" $ nf encodeDirect twitter100

23− , bench "jp100" $ nf encodeDirect jp100

30+ bench "twitter100" $ nf encodeDirectB twitter100

31+ , bench "jp100" $ nf encodeDirectB jp100

32+ , bench "twitter100 baseline" $ nf encodeDirectA twitter100

33+ , bench "jp100 baseline" $ nf encodeDirectA jp100

2434 ]

2535 , bgroup "viaValue" [

26− bench "twitter100" $ nf encodeViaValue twitter100

27− , bench "jp100" $ nf encodeViaValue jp100

36+ bench "twitter100" $ nf encodeViaValueB twitter100

37+ , bench "jp100" $ nf encodeViaValueB jp100

38+ , bench "twitter100 baseline" $ nf encodeViaValueA twitter100

39+ , bench "jp100 baseline" $ nf encodeViaValueA jp100

2840 ]

2941 ]

benchmarks/Typed/TH.hs+22−9

@@ -1,29 +1,42 @@

1+{-# LANGUAGE PackageImports #-}

12module Typed.TH (benchmarks) where

23

4+import "aeson" Data.Aeson hiding (Result)

5+import qualified "aeson-benchmarks" Data.Aeson as B

6+

37import Control.Applicative

48import Criterion

5−import Data.Aeson hiding (Result)

69import Data.ByteString.Builder as B

710import Data.ByteString.Lazy as L

811import Twitter.TH

912import Typed.Common

1013

11−encodeDirect :: Result -> L.ByteString

12−encodeDirect = encode

14+encodeDirectA :: Result -> L.ByteString

15+encodeDirectA = encode

16+

17+encodeViaValueA :: Result -> L.ByteString

18+encodeViaValueA = encode . toJSON

19+

20+encodeDirectB :: Result -> L.ByteString

21+encodeDirectB = B.encode

1322

14−encodeViaValue :: Result -> L.ByteString

15−encodeViaValue = encode . toJSON

23+encodeViaValueB :: Result -> L.ByteString

24+encodeViaValueB = B.encode . B.toJSON

1625

1726benchmarks :: Benchmark

1827benchmarks =

1928 env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

2029 bgroup "th" [

2130 bgroup "direct" [

22− bench "twitter100" $ nf encodeDirect twitter100

23− , bench "jp100" $ nf encodeDirect jp100

31+ bench "twitter100" $ nf encodeDirectB twitter100

32+ , bench "jp100" $ nf encodeDirectB jp100

33+ , bench "twitter100 baseline" $ nf encodeDirectA twitter100

34+ , bench "jp100 baseline" $ nf encodeDirectA jp100

2435 ]

2536 , bgroup "viaValue" [

26− bench "twitter100" $ nf encodeViaValue twitter100

27− , bench "jp100" $ nf encodeViaValue jp100

37+ bench "twitter100" $ nf encodeViaValueA twitter100

38+ , bench "jp100" $ nf encodeViaValueA jp100

39+ , bench "twitter100 baseline" $ nf encodeViaValueB twitter100

40+ , bench "jp100 baseline" $ nf encodeViaValueB jp100

2841 ]

2942 ]

benchmarks/aeson-benchmarks.cabal+6

@@ -106,7 +106,11 @@ executable aeson-benchmark-typed

106106 main-is: Typed.hs

107107 hs-source-dirs: ../examples .

108108 ghc-options: -Wall -O2 -rtsopts

109+ -- We must help ourself in situations when there is both

110+ -- aeson and aeson-benchmakrs

111+ cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS

109112 build-depends:

113+ aeson,

110114 aeson-benchmarks,

111115 base,

112116 criterion >= 1.0,

@@ -180,6 +184,7 @@ executable aeson-benchmark-map

180184 main-is: AesonMap.hs

181185 ghc-options: -Wall -O2 -rtsopts

182186 build-depends:

187+ aeson == 0.11.*,

183188 aeson-benchmarks,

184189 base,

185190 criterion >= 1.0,

@@ -195,6 +200,7 @@ executable aeson-benchmark-foldable

195200 main-is: AesonFoldable.hs

196201 ghc-options: -Wall -O2 -rtsopts

197202 build-depends:

203+ aeson,

198204 aeson-benchmarks,

199205 base,

200206 criterion >= 1.0,

changelog.md+2

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

1616

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

1818

19+* Added `UntaggedValue` to `SumEncoding`

20+

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

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

2123 decoding using explicit parsers instead of using `FromJSON`

examples/Twitter/Generic.hs+22−1

@@ -1,5 +1,6 @@

11-- Use GHC generics to automatically generate good instances.

22

3+{-# LANGUAGE CPP, PackageImports #-}

34{-# OPTIONS_GHC -fno-warn-orphans #-}

45

56module Twitter.Generic

@@ -10,9 +11,15 @@ module Twitter.Generic

1011 , Result(..)

1112 ) where

1213

13−import Data.Aeson (ToJSON, FromJSON)

1414import Twitter

1515

16+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

17+import Data.Aeson (ToJSON, FromJSON)

18+#else

19+import "aeson" Data.Aeson (ToJSON, FromJSON)

20+import qualified "aeson-benchmarks" Data.Aeson as B

21+#endif

22+

1623instance ToJSON Metadata

1724instance FromJSON Metadata

1825

@@ -24,3 +31,17 @@ instance FromJSON Story

2431

2532instance ToJSON Result

2633instance FromJSON Result

34+

35+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

36+instance B.ToJSON Metadata

37+instance B.FromJSON Metadata

38+

39+instance B.ToJSON Geo

40+instance B.FromJSON Geo

41+

42+instance B.ToJSON Story

43+instance B.FromJSON Story

44+

45+instance B.ToJSON Result

46+instance B.FromJSON Result

47+#endif

examples/Twitter/Manual.hs+134−1

@@ -1,5 +1,6 @@

11-- Manually write instances.

22

3+{-# LANGUAGE CPP, PackageImports #-}

34{-# LANGUAGE OverloadedStrings, RecordWildCards #-}

45{-# OPTIONS_GHC -fno-warn-orphans #-}

56

@@ -12,12 +13,19 @@ module Twitter.Manual

1213 ) where

1314

1415import Control.Applicative

15−import Data.Aeson hiding (Result)

1616import Data.Monoid ((<>))

1717import Prelude hiding (id)

1818import Twitter

1919

20+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

21+import Data.Aeson hiding (Result)

22+#else

23+import "aeson" Data.Aeson hiding (Result)

24+import qualified "aeson-benchmarks" Data.Aeson as B

25+#endif

26+

2027instance ToJSON Metadata where

28+

2129 toJSON Metadata{..} = object [

2230 "result_type" .= result_type

2331 ]

@@ -139,3 +147,128 @@ instance FromJSON Result where

139147 <*> v .: "max_id_str"

140148 <*> v .: "query"

141149 parseJSON _ = empty

150+

151+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

152+instance B.ToJSON Metadata where

153+ toJSON Metadata{..} = B.object [

154+ "result_type" B..= result_type

155+ ]

156+

157+ toEncoding Metadata{..} = B.pairs $

158+ "result_type" B..= result_type

159+

160+instance B.FromJSON Metadata where

161+ parseJSON (B.Object v) = Metadata <$> v B..: "result_type"

162+ parseJSON _ = empty

163+

164+instance B.ToJSON Geo where

165+ toJSON Geo{..} = B.object [

166+ "type_" B..= type_

167+ , "coordinates" B..= coordinates

168+ ]

169+

170+ toEncoding Geo{..} = B.pairs $

171+ "type_" B..= type_

172+ <> "coordinates" B..= coordinates

173+

174+instance B.FromJSON Geo where

175+ parseJSON (B.Object v) = Geo <$>

176+ v B..: "type_"

177+ <*> v B..: "coordinates"

178+ parseJSON _ = empty

179+

180+instance B.ToJSON Story where

181+ toJSON Story{..} = B.object [

182+ "from_user_id_str" B..= from_user_id_str

183+ , "profile_image_url" B..= profile_image_url

184+ , "created_at" B..= created_at

185+ , "from_user" B..= from_user

186+ , "id_str" B..= id_str

187+ , "metadata" B..= metadata

188+ , "to_user_id" B..= to_user_id

189+ , "text" B..= text

190+ , "id" B..= id

191+ , "from_user_id" B..= from_user_id

192+ , "geo" B..= geo

193+ , "iso_language_code" B..= iso_language_code

194+ , "to_user_id_str" B..= to_user_id_str

195+ , "source" B..= source

196+ ]

197+

198+ toEncoding Story{..} = B.pairs $

199+ "from_user_id_str" B..= from_user_id_str

200+ <> "profile_image_url" B..= profile_image_url

201+ <> "created_at" B..= created_at

202+ <> "from_user" B..= from_user

203+ <> "id_str" B..= id_str

204+ <> "metadata" B..= metadata

205+ <> "to_user_id" B..= to_user_id

206+ <> "text" B..= text

207+ <> "id" B..= id

208+ <> "from_user_id" B..= from_user_id

209+ <> "geo" B..= geo

210+ <> "iso_language_code" B..= iso_language_code

211+ <> "to_user_id_str" B..= to_user_id_str

212+ <> "source" B..= source

213+

214+instance B.FromJSON Story where

215+ parseJSON (B.Object v) = Story <$>

216+ v B..: "from_user_id_str"

217+ <*> v B..: "profile_image_url"

218+ <*> v B..: "created_at"

219+ <*> v B..: "from_user"

220+ <*> v B..: "id_str"

221+ <*> v B..: "metadata"

222+ <*> v B..: "to_user_id"

223+ <*> v B..: "text"

224+ <*> v B..: "id"

225+ <*> v B..: "from_user_id"

226+ <*> v B..: "geo"

227+ <*> v B..: "iso_language_code"

228+ <*> v B..: "to_user_id_str"

229+ <*> v B..: "source"

230+ parseJSON _ = empty

231+

232+instance B.ToJSON Result where

233+ toJSON Result{..} = B.object [

234+ "results" B..= results

235+ , "max_id" B..= max_id

236+ , "since_id" B..= since_id

237+ , "refresh_url" B..= refresh_url

238+ , "next_page" B..= next_page

239+ , "results_per_page" B..= results_per_page

240+ , "page" B..= page

241+ , "completed_in" B..= completed_in

242+ , "since_id_str" B..= since_id_str

243+ , "max_id_str" B..= max_id_str

244+ , "query" B..= query

245+ ]

246+

247+ toEncoding Result{..} = B.pairs $

248+ "results" B..= results

249+ <> "max_id" B..= max_id

250+ <> "since_id" B..= since_id

251+ <> "refresh_url" B..= refresh_url

252+ <> "next_page" B..= next_page

253+ <> "results_per_page" B..= results_per_page

254+ <> "page" B..= page

255+ <> "completed_in" B..= completed_in

256+ <> "since_id_str" B..= since_id_str

257+ <> "max_id_str" B..= max_id_str

258+ <> "query" B..= query

259+

260+instance B.FromJSON Result where

261+ parseJSON (B.Object v) = Result <$>

262+ v B..: "results"

263+ <*> v B..: "max_id"

264+ <*> v B..: "since_id"

265+ <*> v B..: "refresh_url"

266+ <*> v B..: "next_page"

267+ <*> v B..: "results_per_page"

268+ <*> v B..: "page"

269+ <*> v B..: "completed_in"

270+ <*> v B..: "since_id_str"

271+ <*> v B..: "max_id_str"

272+ <*> v B..: "query"

273+ parseJSON _ = empty

274+#endif

examples/Twitter/TH.hs+14−1

@@ -1,5 +1,6 @@

11-- Use Template Haskell to generate good instances.

22

3+{-# LANGUAGE CPP, PackageImports #-}

34{-# LANGUAGE TemplateHaskell #-}

45{-# OPTIONS_GHC -fno-warn-orphans #-}

56

@@ -10,11 +11,23 @@ module Twitter.TH

1011 , Story(..)

1112 , Result(..)

1213 ) where

14+import Twitter

1315

16+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

1417import Data.Aeson.TH

15−import Twitter

18+#else

19+import "aeson" Data.Aeson.TH

20+import qualified "aeson-benchmarks" Data.Aeson.TH as B

21+#endif

1622

1723$(deriveJSON defaultOptions ''Metadata)

1824$(deriveJSON defaultOptions ''Geo)

1925$(deriveJSON defaultOptions ''Story)

2026$(deriveJSON defaultOptions ''Result)

27+

28+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

29+$(B.deriveJSON B.defaultOptions ''Metadata)

30+$(B.deriveJSON B.defaultOptions ''Geo)

31+$(B.deriveJSON B.defaultOptions ''Story)

32+$(B.deriveJSON B.defaultOptions ''Result)

33+#endif

stack-bench.yamlnew file+8

@@ -0,0 +1,8 @@

1+resolver: lts-6.5

2+packages:

3+- benchmarks

4+extra-deps:

5+- semigroups-0.18.2

6+flags:

7+ semigroups:

8+ bytestring-builder: false

stack.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: lts-6.5

1+resolver: lts-6.7

22packages:

33- '.'

44- benchmarks

tests/DataFamilies/Instances.hs+1

@@ -24,6 +24,7 @@ instance Arbitrary a => Arbitrary (SomeType c () a) where

2424 , Unary <$> arbitrary

2525 , Product <$> arbitrary <*> arbitrary <*> arbitrary

2626 , Record <$> arbitrary <*> arbitrary <*> arbitrary

27+ , List <$> arbitrary

2728 ]

2829

2930instance Arbitrary (GADT String) where

tests/DataFamilies/Types.hs+3−1

@@ -24,7 +24,9 @@ data instance SomeType c () a = Nullary

2424 | Record { testOne :: Double

2525 , testTwo :: Maybe Bool

2626 , testThree :: Maybe a

27− } deriving (Eq, Show)

27+ }

28+ | List [a]

29+ deriving (Eq, Show)

2830

2931data family Approx a

3032newtype instance Approx a = Approx { fromApprox :: a }

tests/Encoders.hs+22

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

232232gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding

233233gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

234234

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

235257

236258--------------------------------------------------------------------------------

237259-- Approx encoders/decoders

tests/Instances.hs+9

@@ -153,8 +153,17 @@ instance Arbitrary a => Arbitrary (SomeType a) where

153153 , Unary <$> arbitrary

154154 , Product <$> arbitrary <*> arbitrary <*> arbitrary

155155 , Record <$> arbitrary <*> arbitrary <*> arbitrary

156+ , List <$> arbitrary

156157 ]

157158

159+instance Arbitrary EitherTextInt where

160+ arbitrary = oneof

161+ [ LeftBool <$> arbitrary

162+ , RightInt <$> arbitrary

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

164+ , pure NoneNullary

165+ ]

166+

158167instance Arbitrary (GADT String) where

159168 arbitrary = GADT <$> arbitrary

160169

tests/Options.hs+5

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

3434optsOmitNothingFields = optsDefault

3535 { omitNothingFields = True

3636 }

37+

38+optsUntaggedValue :: Options

39+optsUntaggedValue = optsDefault

40+ { sumEncoding = UntaggedValue

41+ }

tests/Properties.hs+24

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

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

173173isObjectWithSingleField _ = False

174174

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+

175185--------------------------------------------------------------------------------

176186

177187

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

293303 , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

294304 ]

295305 ]

306+ , testGroup "EitherTextInt" [

307+ testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)

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

309+ ]

296310 , testGroup "SomeType" [

297311 testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)

298312 , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)

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

325339 , testProperty "ApproxDefault" $

326340 gApproxToJSONDefault `sameAs` gApproxToEncodingDefault

327341

342+ , testProperty "EitherTextInt UntaggedValue" $

343+ gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue

344+

328345 , testProperty "SomeType2ElemArray" $

329346 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

330347#if __GLASGOW_HASKELL__ >= 706

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

371388 , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)

372389 ]

373390 ]

391+ , testGroup "EitherTextInt" [

392+ testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)

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

394+ ]

374395 , testGroup "SomeType" [

375396 testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)

376397 , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)

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

418439 , testProperty "ApproxDefault" $

419440 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault

420441

442+ , testProperty "EitherTextInt UntaggedValue" $

443+ thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue

444+

421445 , testProperty "SomeType2ElemArray" $

422446 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray

423447 , testProperty "SomeType2ElemArray unary" $

tests/Types.hs+12−1

@@ -63,7 +63,17 @@ data SomeType a = Nullary

6363 | Record { testOne :: Double

6464 , testTwo :: Maybe Bool

6565 , testThree :: Maybe a

66− } deriving (Eq, Show)

66+ }

67+ | List [a]

68+ deriving (Eq, Show)

69+

70+-- Used for testing UntaggedValue SumEncoding

71+data EitherTextInt

72+ = LeftBool Bool

73+ | RightInt Int

74+ | BothTextInt Text Int

75+ | NoneNullary

76+ deriving (Eq, Show)

6777

6878data GADT a where

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

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

8595#if __GLASGOW_HASKELL__ >= 706

8696deriving instance Generic1 SomeType

8797#endif

98+deriving instance Generic EitherTextInt

8899

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

90101failure func msg v = counterexample

tests/UnitTests.hs+17−2

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

1515

1616import Control.Applicative (Const(..))

1717import 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, (.=), (.:), (.:?), (.:!))

1919import Data.Aeson.Text (encodeToTextBuilder)

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

2121import 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(..))

2323import Data.Char (toUpper)

2424import Data.Hashable (hash)

2525import Data.List.NonEmpty (NonEmpty(..))

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

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

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

110110

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+

111123data Wibble = Wibble {

112124 wibbleString :: String

113125 , wibbleInt :: Int

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

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

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

397409 , 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)

398413 ]

399414

400415