master..f62d492 · typeable/aeson

git.iko.soy/typeable/aeson

117 files changed+3971−7013

unifiedsplit

.gitattributes−1 .gitignore−7 .hlint.yaml−11 .travis.yml+16−43 CONTRIBUTING.md+1−39 Data/Aeson.hs+12−82 Data/Aeson/Encode.hs+1−2 Data/Aeson/Encoding.hs+1−3 Data/Aeson/Encoding/Builder.hs+81−6 Data/Aeson/Encoding/Internal.hs+2−9 Data/Aeson/Internal.hs+1−1 Data/Aeson/Internal/Functions.hs+1−1 Data/Aeson/Internal/Time.hs+41−1 Data/Aeson/Parser.hs+4−13 Data/Aeson/Parser/Internal.hs+64−254 Data/Aeson/Parser/Time.hs+103−18 Data/Aeson/Parser/Unescape.hs+51−11 Data/Aeson/QQ/Simple.hs−25 Data/Aeson/TH.hs+896−445 Data/Aeson/Text.hs+4−5 Data/Aeson/Types.hs+5−49 Data/Aeson/Types/Class.hs+7−26 Data/Aeson/Types/FromJSON.hs+447−950 Data/Aeson/Types/Generic.hs+8−12 Data/Aeson/Types/Internal.hs+26−175 Data/Aeson/Types/ToJSON.hs+532−587 Makefile−2 README.markdown+2−1 aeson.cabal+62−102 attoparsec-iso8601/Data/Attoparsec/Time.hs−148 attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs−64 attoparsec-iso8601/LICENSE−30 attoparsec-iso8601/README.md−19 attoparsec-iso8601/attoparsec-iso8601.cabal−55 attoparsec-iso8601/changelog.md−5 benchmarks/AesonCompareAutoInstances.hs+229 benchmarks/AesonEncode.hs+5−4 benchmarks/AesonFoldable.hs+42−14 benchmarks/AesonMap.hs+56−39 benchmarks/AesonParse.hs+5−3 benchmarks/AesonTuples.hs+2−1 benchmarks/Auto/G/BigProduct.hs−33 benchmarks/Auto/G/BigRecord.hs−33 benchmarks/Auto/G/BigSum.hs−28 benchmarks/Auto/G/D.hs−44 benchmarks/Auto/T/BigProduct.hs−27 benchmarks/Auto/T/BigRecord.hs−27 benchmarks/Auto/T/BigSum.hs−22 benchmarks/Auto/T/D.hs−38 benchmarks/AutoCompare.hs−73 benchmarks/Compare.hs+5−10 benchmarks/Compare/BufferBuilder.hs+3−2 benchmarks/Compare/JsonBench.hs+10−18 benchmarks/Compare/JsonBuilder.hs+3−2 benchmarks/CompareWithJSON.hs+21−33 benchmarks/Dates.hs+9−10 benchmarks/Escape.hs−32 benchmarks/Issue673.hs−165 benchmarks/JsonParse.hs+2−3 benchmarks/Micro.hs+6−8 benchmarks/Options.hs+4−1 benchmarks/ReadFile.hs+2−2 benchmarks/Typed.hs+1−5 benchmarks/Typed/Common.hs+8−1 benchmarks/Typed/Generic.hs+25−27 benchmarks/Typed/Manual.hs+24−26 benchmarks/Typed/TH.hs+24−26 benchmarks/aeson-benchmarks.cabal+62−183 cabal.project−5 changelog.md+4−204 examples/Generic.hs+1−1 examples/Simplest.hs+1−1 examples/TemplateHaskell.hs+1−1 examples/Twitter.hs+2−4 examples/Twitter/Generic.hs+37−31 examples/Twitter/Manual.hs+136−3 examples/Twitter/Options.hs−10 examples/Twitter/TH.hs+19−7 ffi/Data/Aeson/Parser/UnescapeFFI.hs−52 pure/Data/Aeson/Parser/UnescapePure.hs−254 run-hlint.sh−7 stack-bench.yaml+6−10 stack-ffi-unescape.yaml−9 stack-lts12.yaml−15 stack-lts6.yaml+10 stack-lts7.yaml+6 stack-nightly.yaml+1−6 tests/DataFamilies/Encoders.hs+2−2 tests/DataFamilies/Instances.hs+1−2 tests/DataFamilies/Properties.hs+5−6 tests/DataFamilies/Types.hs+2−2 tests/Encoders.hs+8−123 tests/ErrorMessages.hs−224 tests/Functions.hs+1−2 tests/Instances.hs+68−7 tests/JSONTestSuite/parsers/test_haskell-aeson/src/Main.hs+1−1 tests/JSONTestSuite/parsers/test_haskell-aeson/testaeson.cabal+3−5 tests/JSONTestSuite/test_parsing/n_structure_..json → tests/JSONTestSuite/test_parsing/n_structure_<.>.json tests/JSONTestSuite/test_parsing/n_structure_null.json → tests/JSONTestSuite/test_parsing/n_structure_<null>.json tests/Options.hs+2−26 tests/PropUtils.hs−208 tests/Properties.hs+448−17 tests/PropertyGeneric.hs−116 tests/PropertyKeys.hs−40 tests/PropertyRTFunctors.hs−51 tests/PropertyRoundTrip.hs−74 tests/PropertyTH.hs−130 tests/SerializationFormatSpec.hs−294 tests/Tests.hs+3−5 tests/Types.hs+5−40 tests/UnitTests.hs+278−331 tests/UnitTests/NullaryConstructors.hs+3−8 tests/golden/generic.expected−48 tests/golden/simple.expected−22 travis/cabal_macros.h−448 travis/install.sh−11 travis/script.sh+1−8

.gitattributesdeleted−1

@@ -1 +0,0 @@

1−tests/JSONTestSuite/* linguist-vendored

.gitignore−7

@@ -1,11 +1,7 @@

11dist

2−dist-newstyle

3−.ghc.environment.*

42.cabal-sandbox/

53cabal.sandbox.config

64.stack-work/

7−.stack-work-bench/

8−*.yaml.lock

106*.o

117*.hi

@@ -14,9 +10,6 @@ cabal.sandbox.config

1410.\#*

1511\#*

1612

17−# Emacs backup files

18−*~

19−

2013benchmarks/AesonEncode

2114

2215tests/qc

.hlint.yamldeleted−11

@@ -1,11 +0,0 @@

1−# Ignore some builtin hints

2−- ignore:

3− name: "Reduce duplication"

4− within:

5− - Data.Aeson.Types.ToJSON

6−- ignore:

7− name: "Eta reduce"

8−- ignore:

9− name: "Use newtype instead of data"

10− within:

11− - Data.Aeson.Types.Internal

.travis.yml+16−43

@@ -12,58 +12,31 @@ cache:

1212 - $HOME/.stack

1313 - $HOME/.cabsnap

1414 - $HOME/.cabal/packages

15− - $HOME/.cabal/store

1615

1716before_cache:

1817 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

20− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

21− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

18+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

2419

2520matrix:

2621 include:

27−

28− - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.4

29− compiler: ": #GHC 8.4.4"

30− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

31−

32− - env: BUILD=stack CABALVER=2.4 GHCVER=8.6.5 STACK_YAML=stack-bench.yaml

33− compiler: ": #GHC 8.6.5"

34− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

35−

36− - env: BUILD=stack CABALVER=2.2 GHCVER=8.6.5 STACK_YAML=stack-ffi-unescape.yaml

37− compiler: ": #GHC 8.6.5"

38− addons: {apt: {packages: [cabal-install-2.2,ghc-8.6.5], sources: [hvr-ghc]}}

39−

40− - env: BUILD=cabal2 CABALVER=3.0 GHCVER=8.8.1

41− compiler: ": #GHC 8.8.1"

42− addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1], sources: [hvr-ghc]}}

43−

44− - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.5

45− compiler: ": #GHC 8.6.5"

46− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

47−

48− - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.4

49− compiler: ": #GHC 8.4.4"

50− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

51−

52− - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2

53− compiler: ": #GHC 8.2.2"

54− addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}

55−

56− - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2

57− compiler: ": #GHC 8.0.2"

58− addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}

59−

60− - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3

61− compiler: ": #GHC 7.10.3"

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

63−

22+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.4.2

23+ compiler: ": #GHC 7.4.2"

24+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}

25+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.6.3

26+ compiler: ": #GHC 7.6.3"

27+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}

6428 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4

6529 compiler: ": #GHC 7.8.4"

6630 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

31+ - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.2

32+ compiler: ": #GHC 7.10.2"

33+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}

34+ - env: BUILD=cabal CABALVER=1.24 GHCVER=8.0.1

35+ compiler: ": #GHC 8.0.1"

36+ 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 STACK_YAML=stack-bench.yaml

38+ compiler: ": #GHC 7.10.3"

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

6740

6841before_install:

6942 - unset CC

CONTRIBUTING.md+1−39

@@ -8,7 +8,7 @@ Changes that affect users of aeson should be mentioned in `changelog.md`. It sho

88 * When it should be used

99 * What it supersedes

1010

11−Add this entry under an `## Upcoming` header above existing releases.

11+Add this entry under an `# Upcoming` header above existing releases.

1212

1313The exact format of entries is not important as we'll go through everything before a release is made.

1414

@@ -58,41 +58,3 @@ import Foo as F

5858import Qux (Q(..), q)

5959import qualified A

6060```

61−

62−## Development Workflow (If you plan on using Stack)

63−

64−Here we outline a general workflow new contributors could adopt for a nice incremental development experience.

65−

66−The root folder consists of two stack-*.yaml config files.

67−

68−1. stack-nightly.yaml - Config file defines all the settings to build and test any changes.

69−2. stack-bench.yaml - Used to run benchmark tests.

70−3. stack-ffi-unescape.yaml - This is for replacing certain parts with a C-implementation.

71−

72−Therefore, a ghci development experience would be:

73−

74−1. `stack ghci --stack-yaml stack-nightly.yaml --test`

75−2. :r to recompile

76−3. `main` to run all tests, or `:main --pattern Foo` to run specific tests matched by pattern.

77−

78−Some discussion on this topic can also be found here [here](https://github.com/bos/aeson/issues/733)

79−

80−Of course before submitting a PR, the following steps are recommended:

81−

82−1. 'stack test --stack-yaml stack-nightly.yaml` - Run the entire suite of tests

83−2. `make hlint` - Run hlint on the source folders.

84−3. 'stack test --stack-yaml stack-bench.yaml` - Run the benchmark tests if you believe your changes could affect the benchmarks.

85−

86−## Development Workflow (If you plan on using Cabal)

87−

88−A ghci development experience would be:

89−

90−1. `cabal new-repl test:tests`

91−2. `:r` to recompile

92−3. `Main.main` to run all tests, or `:m Main; :main --pattern Foo` to run specific tests matched by pattern.

93−

94−Of course before submitting a PR, the following steps are recommended:

95−

96−1. `cabal new-test` - Run the entire suite of tests

97−2. `make hlint` - Run hlint on the source folders.

98−3. Uncomment the `benchmarks` line in `cabal.project` - Run the benchmark tests if you believe your changes could affect the benchmarks.

Data/Aeson.hs+12−82

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32-- Module: Data.Aeson

@@ -39,16 +38,11 @@ module Data.Aeson

3938 , eitherDecode

4039 , eitherDecode'

4140 , encode

42− , encodeFile

4341 -- ** Variants for strict bytestrings

4442 , decodeStrict

45− , decodeFileStrict

4643 , decodeStrict'

47− , decodeFileStrict'

4844 , eitherDecodeStrict

49− , eitherDecodeFileStrict

5045 , eitherDecodeStrict'

51− , eitherDecodeFileStrict'

5246 -- * Core JSON types

5347 , Value(..)

5448 , Encoding

@@ -63,18 +57,11 @@ module Data.Aeson

6357 , fromJSON

6458 , ToJSON(..)

6559 , KeyValue(..)

66− , (<?>)

67− , JSONPath

6860 -- ** Keys for maps

6961 , ToJSONKey(..)

7062 , ToJSONKeyFunction(..)

7163 , FromJSONKey(..)

7264 , FromJSONKeyFunction(..)

73− -- *** Generic keys

74− , GToJSONKey()

75− , genericToJSONKey

76− , GFromJSONKey()

77− , genericFromJSONKey

7865 -- ** Liftings to unary and binary type constructors

7966 , FromJSON1(..)

8067 , parseJSON1

@@ -89,8 +76,8 @@ module Data.Aeson

8976 -- ** Generic JSON classes and options

9077 , GFromJSON(..)

9178 , FromArgs(..)

92− , GToJSON

93− , GToEncoding

79+ , GToJSON(..)

80+ , GToEncoding(..)

9481 , ToArgs(..)

9582 , Zero

9683 , One

@@ -100,34 +87,15 @@ module Data.Aeson

10087 , genericLiftToEncoding

10188 , genericParseJSON

10289 , genericLiftParseJSON

103− -- ** Generic and TH encoding configuration

104− , Options

10590 , defaultOptions

106− -- *** Options fields

107− -- $optionsFields

108− , fieldLabelModifier

109− , constructorTagModifier

110− , allNullaryToStringTag

111− , omitNothingFields

112− , sumEncoding

113− , unwrapUnaryRecords

114− , tagSingleConstructors

115− -- *** Options utilities

116− , SumEncoding(..)

117− , camelTo2

118− , defaultTaggedObject

119− -- ** Options for object keys

120− , JSONKeyOptions

121− , keyModifier

122− , defaultJSONKeyOptions

12391

12492 -- * Inspecting @'Value's@

12593 , withObject

12694 , withText

12795 , withArray

96+ , withNumber

12897 , withScientific

12998 , withBool

130− , withEmbeddedJSON

13199 -- * Constructors and accessors

132100 , Series

133101 , pairs

@@ -140,16 +108,16 @@ module Data.Aeson

140108 -- * Parsing

141109 , json

142110 , json'

143− , parseIndexedJSON

144111 ) where

145112

113+import Prelude ()

146114import Prelude.Compat

147115

148−import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)

116+import Data.Aeson.Types.FromJSON (ifromJSON)

149117import Data.Aeson.Encoding (encodingToLazyByteString)

150118import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')

151119import Data.Aeson.Types

152−import Data.Aeson.Types.Internal (JSONPath, formatError, (<?>))

120+import Data.Aeson.Types.Internal (JSONPath, formatError)

153121import qualified Data.ByteString as B

154122import qualified Data.ByteString.Lazy as L

155123

@@ -159,10 +127,6 @@ import qualified Data.ByteString.Lazy as L

159127encode :: (ToJSON a) => a -> L.ByteString

160128encode = encodingToLazyByteString . toEncoding

161129

162−-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file.

163−encodeFile :: (ToJSON a) => FilePath -> a -> IO ()

164−encodeFile fp = L.writeFile fp . encode

165−

166130-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.

167131-- If this fails due to incomplete or invalid input, 'Nothing' is

168132-- returned.

@@ -189,18 +153,6 @@ decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a

189153decodeStrict = decodeStrictWith jsonEOF fromJSON

190154{-# INLINE decodeStrict #-}

191155

192−-- | Efficiently deserialize a JSON value from a file.

193−-- If this fails due to incomplete or invalid input, 'Nothing' is

194−-- returned.

195−--

196−-- The input file's content must consist solely of a JSON document,

197−-- with no trailing data except for whitespace.

198−--

199−-- This function parses immediately, but defers conversion. See

200−-- 'json' for details.

201−decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a)

202−decodeFileStrict = fmap decodeStrict . B.readFile

203−

204156-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.

205157-- If this fails due to incomplete or invalid input, 'Nothing' is

206158-- returned.

@@ -227,18 +179,6 @@ decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a

227179decodeStrict' = decodeStrictWith jsonEOF' fromJSON

228180{-# INLINE decodeStrict' #-}

229181

230−-- | Efficiently deserialize a JSON value from a file.

231−-- If this fails due to incomplete or invalid input, 'Nothing' is

232−-- returned.

233−--

234−-- The input file's content must consist solely of a JSON document,

235−-- with no trailing data except for whitespace.

236−--

237−-- This function parses and performs conversion immediately. See

238−-- 'json'' for details.

239−decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a)

240−decodeFileStrict' = fmap decodeStrict' . B.readFile

241−

242182eitherFormatError :: Either (JSONPath, String) a -> Either String a

243183eitherFormatError = either (Left . uncurry formatError) Right

244184{-# INLINE eitherFormatError #-}

@@ -254,12 +194,6 @@ eitherDecodeStrict =

254194 eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON

255195{-# INLINE eitherDecodeStrict #-}

256196

257−-- | Like 'decodeFileStrict' but returns an error message when decoding fails.

258−eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a)

259−eitherDecodeFileStrict =

260− fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON) . B.readFile

261−{-# INLINE eitherDecodeFileStrict #-}

262−

263197-- | Like 'decode'' but returns an error message when decoding fails.

264198eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a

265199eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON

@@ -271,12 +205,6 @@ eitherDecodeStrict' =

271205 eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON

272206{-# INLINE eitherDecodeStrict' #-}

273207

274−-- | Like 'decodeFileStrict'' but returns an error message when decoding fails.

275−eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a)

276−eitherDecodeFileStrict' =

277− fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON) . B.readFile

278−{-# INLINE eitherDecodeFileStrict' #-}

279−

280208-- $use

281209--

282210-- This section contains basic information on the different ways to

@@ -346,9 +274,11 @@ eitherDecodeFileStrict' =

346274-- > {-# LANGUAGE OverloadedStrings #-}

347275-- >

348276-- > instance FromJSON Person where

349−-- > parseJSON = withObject "Person" $ \v -> Person

350−-- > <$> v .: "name"

351−-- > <*> v .: "age"

277+-- > parseJSON (Object v) = Person <$>

278+-- > v .: "name" <*>

279+-- > v .: "age"

280+-- > -- A non-Object value is of the wrong type, so fail.

281+-- > parseJSON _ = empty

352282--

353283-- We can now parse the JSON data like so:

354284--

@@ -438,7 +368,7 @@ eitherDecodeFileStrict' =

438368-- The 'Object' type contains JSON objects:

439369--

440370-- > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object

441−-- > Just (fromList [("name",String "Dave"),("age",Number 2)])

371+-- > Just (fromList) [("name",String "Dave"),("age",Number 2)]

442372--

443373-- You can extract values from it with a parser using 'parse',

444374-- 'parseEither' or, in this example, 'parseMaybe':

Data/Aeson/Encode.hs+1−2

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32-- Module: Data.Aeson.Encode

@@ -9,13 +8,13 @@

98-- Portability: portable

109--

1110-- This module is left to supply limited backwards-compatibility.

12−

1311module Data.Aeson.Encode {-# DEPRECATED "Use Data.Aeson or Data.Aeson.Text instead" #-}

1412 (

1513 encode

1614 , encodeToTextBuilder

1715 ) where

1816

17+import Prelude ()

1918

2019import Data.ByteString.Lazy (ByteString)

2120import Data.Text.Lazy.Builder (Builder)

Data/Aeson/Encoding.hs+1−3

@@ -1,10 +1,8 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32--

43-- Functions in this module return well-formed 'Encoding''.

54-- Polymorphic variants, which return @'Encoding' a@, return a textual JSON

65-- value, so it can be used as both @'Encoding'' 'Text'@ and @'Encoding' = 'Encoding'' 'Value'@.

7−

86module Data.Aeson.Encoding

97 (

108 -- * Encoding

@@ -16,7 +14,6 @@ module Data.Aeson.Encoding

1614 , Series

1715 , pairs

1816 , pair

19− , pairStr

2017 , pair'

2118 -- * Predicates

2219 , nullEncoding

@@ -51,5 +48,6 @@ module Data.Aeson.Encoding

5148 , value

5249 ) where

5350

51+import Prelude ()

5452

5553import Data.Aeson.Encoding.Internal

Data/Aeson/Encoding/Builder.hs+81−6

@@ -1,6 +1,7 @@

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE OverloadedStrings #-}

45-- |

56-- Module: Data.Aeson.Encoding.Builder

@@ -36,6 +37,7 @@ module Data.Aeson.Encoding.Builder

3637 , ascii5

3738 ) where

3839

40+import Prelude ()

3941import Prelude.Compat

4042

4143import Data.Aeson.Internal.Time

@@ -44,9 +46,8 @@ import Data.ByteString.Builder as B

4446import Data.ByteString.Builder.Prim as BP

4547import Data.ByteString.Builder.Scientific (scientificBuilder)

4648import Data.Char (chr, ord)

47−import Data.Semigroup ((<>))

49+import Data.Monoid ((<>))

4850import Data.Scientific (Scientific, base10Exponent, coefficient)

49−import Data.Text.Encoding (encodeUtf8BuilderEscaped)

5051import Data.Time (UTCTime(..))

5152import Data.Time.Calendar (Day(..), toGregorian)

5253import Data.Time.LocalTime

@@ -55,6 +56,20 @@ import qualified Data.HashMap.Strict as HMS

5556import qualified Data.Text as T

5657import qualified Data.Vector as V

5758

59+#if MIN_VERSION_bytestring(0,10,4)

60+import Data.Text.Encoding (encodeUtf8BuilderEscaped)

61+#else

62+import Data.Bits ((.&.))

63+import Data.Text.Internal (Text(..))

64+import Data.Text.Internal.Unsafe.Shift (shiftR)

65+import Foreign.Ptr (minusPtr, plusPtr)

66+import Foreign.Storable (poke)

67+import qualified Data.ByteString.Builder.Internal as B

68+import qualified Data.ByteString.Builder.Prim.Internal as BP

69+import qualified Data.Text.Array as A

70+import qualified Data.Text.Internal.Encoding.Utf16 as U16

71+#endif

72+

5873-- | Encode a JSON value to a "Data.ByteString" 'B.Builder'.

5974--

6075-- Use this function if you are encoding over the wire, or need to

@@ -133,7 +148,7 @@ c2w c = fromIntegral (ord c)

133148-- | Encode a JSON number.

134149scientific :: Scientific -> Builder

135150scientific s

136− | e < 0 || e > 1024 = scientificBuilder s

151+ | e < 0 = scientificBuilder s

137152 | otherwise = B.integerDec (coefficient s * 10 ^ e)

138153 where

139154 e = base10Exponent s

@@ -201,7 +216,7 @@ timeOfDay64 (TOD h m s)

201216 !(T mh ml) = twoDigits m

202217 !(T sh sl) = twoDigits (fromIntegral real)

203218 (real,frac) = s `quotRem` pico

204− showFrac = ('.',) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)

219+ showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)

205220 trunc12 = (`quotRem` micro) >$<

206221 BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)

207222 digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)

@@ -219,6 +234,7 @@ timeOfDay64 (TOD h m s)

219234 pico = 1000000000000 -- number of picoseconds in 1 second

220235 micro = 1000000 -- number of microseconds in 1 second

221236 milli = 1000 -- number of milliseconds in 1 second

237+{-# INLINE timeOfDay64 #-}

222238

223239timeZone :: TimeZone -> Builder

224240timeZone (TimeZone off _ _)

@@ -254,3 +270,62 @@ twoDigits a = T (digit hi) (digit lo)

254270

255271digit :: Int -> Char

256272digit x = chr (x + 48)

273+

274+#if !(MIN_VERSION_bytestring(0,10,4))

275+-- | Encode text using UTF-8 encoding and escape the ASCII characters using

276+-- a 'BP.BoundedPrim'.

277+--

278+-- Use this function is to implement efficient encoders for text-based formats

279+-- like JSON or HTML.

280+{-# INLINE encodeUtf8BuilderEscaped #-}

281+-- TODO: Extend documentation with references to source code in @blaze-html@

282+-- or @aeson@ that uses this function.

283+encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder

284+encodeUtf8BuilderEscaped be =

285+ -- manual eta-expansion to ensure inlining works as expected

286+ \txt -> B.builder (mkBuildstep txt)

287+ where

288+ bound = max 4 $ BP.sizeBound be

289+

290+ mkBuildstep (Text arr off len) !k =

291+ outerLoop off

292+ where

293+ iend = off + len

294+

295+ outerLoop !i0 !br@(B.BufferRange op0 ope)

296+ | i0 >= iend = k br

297+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)

298+ -- TODO: Use a loop with an integrated bound's check if outRemaining

299+ -- is smaller than 8, as this will save on divisions.

300+ | otherwise = return $ B.bufferFull bound op0 (outerLoop i0)

301+ where

302+ outRemaining = (ope `minusPtr` op0) `div` bound

303+ inpRemaining = iend - i0

304+

305+ goPartial !iendTmp = go i0 op0

306+ where

307+ go !i !op

308+ | i < iendTmp = case A.unsafeIndex arr i of

309+ w | w <= 0x7F -> do

310+ BP.runB be (fromIntegral w) op >>= go (i + 1)

311+ | w <= 0x7FF -> do

312+ poke8 0 $ (w `shiftR` 6) + 0xC0

313+ poke8 1 $ (w .&. 0x3f) + 0x80

314+ go (i + 1) (op `plusPtr` 2)

315+ | 0xD800 <= w && w <= 0xDBFF -> do

316+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))

317+ poke8 0 $ (c `shiftR` 18) + 0xF0

318+ poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80

319+ poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80

320+ poke8 3 $ (c .&. 0x3F) + 0x80

321+ go (i + 2) (op `plusPtr` 4)

322+ | otherwise -> do

323+ poke8 0 $ (w `shiftR` 12) + 0xE0

324+ poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80

325+ poke8 2 $ (w .&. 0x3F) + 0x80

326+ go (i + 1) (op `plusPtr` 3)

327+ | otherwise =

328+ outerLoop i (B.BufferRange op ope)

329+ where

330+ poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)

331+#endif

Data/Aeson/Encoding/Internal.hs+2−9

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

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE EmptyDataDecls #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

43{-# LANGUAGE OverloadedStrings #-}

54{-# LANGUAGE RankNTypes #-}

6−

75module Data.Aeson.Encoding.Internal

86 (

97 -- * Encoding

@@ -15,7 +13,6 @@ module Data.Aeson.Encoding.Internal

1513 , Series (..)

1614 , pairs

1715 , pair

18− , pairStr

1916 , pair'

2017 -- * Predicates

2118 , nullEncoding

@@ -57,6 +54,7 @@ module Data.Aeson.Encoding.Internal

5754 , comma, colon, openBracket, closeBracket, openCurly, closeCurly

5855 ) where

5956

57+import Prelude ()

6058import Prelude.Compat

6159

6260import Data.Aeson.Types.Internal (Value)

@@ -82,7 +80,7 @@ newtype Encoding' tag = Encoding {

8280 -- ^ Acquire the underlying bytestring builder.

8381 } deriving (Typeable)

8482

85−-- | Often used synonym for 'Encoding''.

83+-- | Often used synonnym for 'Encoding''.

8684type Encoding = Encoding' Value

8785

8886-- | Make Encoding from Builder.

@@ -126,11 +124,6 @@ data Series = Empty

126124

127125pair :: Text -> Encoding -> Series

128126pair name val = pair' (text name) val

129−{-# INLINE pair #-}

130−

131−pairStr :: String -> Encoding -> Series

132−pairStr name val = pair' (string name) val

133−{-# INLINE pairStr #-}

134127

135128pair' :: Encoding' Text -> Encoding -> Series

136129pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val

Data/Aeson/Internal.hs+1−1

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32-- Module: Data.Aeson.Internal

@@ -23,6 +22,7 @@ module Data.Aeson.Internal

2322 , iparse

2423 ) where

2524

25+import Prelude ()

2626

2727import Data.Aeson.Types.Internal

2828import Data.Aeson.Types.FromJSON (ifromJSON)

Data/Aeson/Internal/Functions.hs+1−1

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32-- Module: Data.Aeson.Functions

@@ -15,6 +14,7 @@ module Data.Aeson.Internal.Functions

1514 , mapKey

1615 ) where

1716

17+import Prelude ()

1818import Prelude.Compat

1919

2020import Data.Hashable (Hashable)

Data/Aeson/Internal/Time.hs+41−1

@@ -17,4 +17,44 @@ module Data.Aeson.Internal.Time

1717 , toTimeOfDay64

1818 ) where

1919

20−import Data.Attoparsec.Time.Internal

20+import Prelude ()

21+import Prelude.Compat

22+

23+import Data.Fixed (Pico)

24+import Data.Int (Int64)

25+import Data.Time

26+import Unsafe.Coerce (unsafeCoerce)

27+

28+#if MIN_VERSION_base(4,7,0)

29+

30+import Data.Fixed (Fixed(MkFixed))

31+

32+toPico :: Integer -> Pico

33+toPico = MkFixed

34+

35+fromPico :: Pico -> Integer

36+fromPico (MkFixed i) = i

37+

38+#else

39+

40+toPico :: Integer -> Pico

41+toPico = unsafeCoerce

42+

43+fromPico :: Pico -> Integer

44+fromPico = unsafeCoerce

45+

46+#endif

47+

48+-- | Like TimeOfDay, but using a fixed-width integer for seconds.

49+data TimeOfDay64 = TOD {-# UNPACK #-} !Int

50+ {-# UNPACK #-} !Int

51+ {-# UNPACK #-} !Int64

52+

53+diffTimeOfDay64 :: DiffTime -> TimeOfDay64

54+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s

55+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000

56+ (m,s) = mp `quotRem` 60000000000000

57+ pico = unsafeCoerce t :: Integer

58+

59+toTimeOfDay64 :: TimeOfDay -> TimeOfDay64

60+toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))

Data/Aeson/Parser.hs+4−13

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

1−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE OverloadedStrings #-}

23-- |

34-- Module: Data.Aeson.Parser

@@ -34,21 +35,10 @@ module Data.Aeson.Parser

3435 json

3536 , value

3637 , jstring

37− , scientific

38− -- ** Handling objects with duplicate keys

39− , jsonWith

40− , jsonLast

41− , jsonAccum

42− , jsonNoDup

4338 -- * Strict parsers

4439 -- $strict

4540 , json'

4641 , value'

47− -- ** Handling objects with duplicate keys

48− , jsonWith'

49− , jsonLast'

50− , jsonAccum'

51− , jsonNoDup'

5242 -- * Decoding without FromJSON instances

5343 , decodeWith

5444 , decodeStrictWith

@@ -56,8 +46,9 @@ module Data.Aeson.Parser

5646 , eitherDecodeStrictWith

5747 ) where

5848

49+import Prelude ()

5950

60−import Data.Aeson.Parser.Internal

51+import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, value, value')

6152

6253-- $lazy

6354--

Data/Aeson/Parser/Internal.hs+64−254

@@ -1,14 +1,10 @@

11{-# LANGUAGE BangPatterns #-}

22{-# LANGUAGE CPP #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

43{-# LANGUAGE OverloadedStrings #-}

54#if MIN_VERSION_ghc_prim(0,3,1)

65{-# LANGUAGE MagicHash #-}

76#endif

8−#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706

9−-- Work around a compiler bug

10−{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}

11−#endif

128-- |

139-- Module: Data.Aeson.Parser.Internal

@@ -25,43 +21,28 @@ module Data.Aeson.Parser.Internal

2521 (

2622 -- * Lazy parsers

2723 json, jsonEOF

28− , jsonWith

29− , jsonLast

30− , jsonAccum

31− , jsonNoDup

3224 , value

3325 , jstring

34− , jstring_

35− , scientific

3626 -- * Strict parsers

3727 , json', jsonEOF'

38− , jsonWith'

39− , jsonLast'

40− , jsonAccum'

41− , jsonNoDup'

4228 , value'

4329 -- * Helpers

4430 , decodeWith

4531 , decodeStrictWith

4632 , eitherDecodeWith

4733 , eitherDecodeStrictWith

48− -- ** Handling objects with duplicate keys

49− , fromListAccum

50− , parseListNoDup

5134 ) where

5235

36+import Prelude ()

5337import Prelude.Compat

5438

5539import Control.Applicative ((<|>))

5640import Control.Monad (void, when)

57−import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))

41+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

5842import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

59−import Data.Function (fix)

60−import Data.Functor.Compat (($>))

6143import Data.Scientific (Scientific)

6244import Data.Text (Text)

63−import Data.Vector (Vector)

64−import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)

45+import Data.Vector as Vector (Vector, empty, fromListN, reverse)

6546import qualified Data.Attoparsec.ByteString as A

6647import qualified Data.Attoparsec.Lazy as L

6748import qualified Data.ByteString as B

@@ -69,12 +50,11 @@ import qualified Data.ByteString.Unsafe as B

6950import qualified Data.ByteString.Lazy as L

7051import qualified Data.HashMap.Strict as H

7152import qualified Data.Scientific as Sci

72−import Data.Aeson.Parser.Unescape (unescapeText)

53+import Data.Aeson.Parser.Unescape

7354

7455#if MIN_VERSION_ghc_prim(0,3,1)

75−import GHC.Base (Int#, (==#), isTrue#, word2Int#, orI#, andI#)

56+import GHC.Base (Int#, (==#), isTrue#, word2Int#)

7657import GHC.Word (Word8(W8#))

77−import qualified Data.Text.Encoding as TE

7858#endif

7959

8060#define BACKSLASH 92

@@ -93,7 +73,7 @@ import qualified Data.Text.Encoding as TE

9373#define C_n 110

9474#define C_t 116

9575

96−-- | Parse any JSON value.

76+-- | Parse a top-level JSON value.

9777--

9878-- The conversion of a parsed value to a Haskell value is deferred

9979-- until the Haskell value is needed. This may improve performance if

@@ -103,15 +83,10 @@ import qualified Data.Text.Encoding as TE

10383-- This function is an alias for 'value'. In aeson 0.8 and earlier, it

10484-- parsed only object or array types, in conformance with the

10585-- now-obsolete RFC 4627.

106−--

107−-- ==== Warning

108−--

109−-- If an object contains duplicate keys, only the first one will be kept.

110−-- For a more flexible alternative, see 'jsonWith'.

11186json :: Parser Value

11287json = value

11388

114−-- | Parse any JSON value.

89+-- | Parse a top-level JSON value.

11590--

11691-- This is a strict version of 'json' which avoids building up thunks

11792-- during parsing; it performs all conversions immediately. Prefer

@@ -120,35 +95,23 @@ json = value

12095-- This function is an alias for 'value''. In aeson 0.8 and earlier, it

12196-- parsed only object or array types, in conformance with the

12297-- now-obsolete RFC 4627.

123−--

124−-- ==== Warning

125−--

126−-- If an object contains duplicate keys, only the first one will be kept.

127−-- For a more flexible alternative, see 'jsonWith''.

12898json' :: Parser Value

12999json' = value'

130100

131−-- Open recursion: object_, object_', array_, array_' are parameterized by the

132−-- toplevel Value parser to be called recursively, to keep the parameter

133−-- mkObject outside of the recursive loop for proper inlining.

101+object_ :: Parser Value

102+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value

134103

135−object_ :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value

136−object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject jstring val

137−{-# INLINE object_ #-}

138−

139−object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value

140−object_' mkObject val' = {-# SCC "object_'" #-} do

141− !vals <- objectValues mkObject jstring' val'

104+object_' :: Parser Value

105+object_' = {-# SCC "object_'" #-} do

106+ !vals <- objectValues jstring' value'

142107 return (Object vals)

143108 where

144109 jstring' = do

145110 !s <- jstring

146111 return s

147−{-# INLINE object_' #-}

148112

149−objectValues :: ([(Text, Value)] -> Either String Object)

150− -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)

151−objectValues mkObject str val = do

113+objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)

114+objectValues str val = do

152115 skipSpace

153116 w <- A.peekWord8'

154117 if w == CLOSE_CURLY

@@ -158,26 +121,22 @@ objectValues mkObject str val = do

158121 -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'

159122 -- and it's much faster because it's doing in place update to the 'HashMap'!

160123 loop acc = do

161− k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")

162− v <- (val A.<?> "object value") <* skipSpace

163− ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'"

124+ k <- str <* skipSpace <* char ':'

125+ v <- val <* skipSpace

126+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY

164127 let acc' = (k, v) : acc

165128 if ch == COMMA

166129 then skipSpace >> loop acc'

167− else case mkObject acc' of

168− Left err -> fail err

169− Right obj -> pure obj

130+ else return (H.fromList acc')

170131{-# INLINE objectValues #-}

171132

172−array_ :: Parser Value -> Parser Value

173−array_ val = {-# SCC "array_" #-} Array <$> arrayValues val

174−{-# INLINE array_ #-}

133+array_ :: Parser Value

134+array_ = {-# SCC "array_" #-} Array <$> arrayValues value

175135

176−array_' :: Parser Value -> Parser Value

177−array_' val = {-# SCC "array_'" #-} do

178− !vals <- arrayValues val

136+array_' :: Parser Value

137+array_' = {-# SCC "array_'" #-} do

138+ !vals <- arrayValues value'

179139 return (Array vals)

180−{-# INLINE array_' #-}

181140

182141arrayValues :: Parser Value -> Parser (Vector Value)

183142arrayValues val = do

@@ -188,133 +147,57 @@ arrayValues val = do

188147 else loop [] 1

189148 where

190149 loop acc !len = do

191− v <- (val A.<?> "json list value") <* skipSpace

192− ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"

150+ v <- val <* skipSpace

151+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE

193152 if ch == COMMA

194153 then skipSpace >> loop (v:acc) (len+1)

195154 else return (Vector.reverse (Vector.fromListN len (v:acc)))

196155{-# INLINE arrayValues #-}

197156

198−-- | Parse any JSON value. Synonym of 'json'.

199−value :: Parser Value

200−value = jsonWith (pure . H.fromList)

201−

202−-- | Parse any JSON value.

203−--

204−-- This parser is parameterized by a function to construct an 'Object'

205−-- from a raw list of key-value pairs, where duplicates are preserved.

206−-- The pairs appear in __reverse order__ from the source.

207−--

208−-- ==== __Examples__

157+-- | Parse any JSON value. You should usually 'json' in preference to

158+-- this function, as this function relaxes the object-or-array

159+-- requirement of RFC 4627.

209160--

210−-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.

211−--

212−-- @

213−-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')

214−-- @

215−--

216−-- 'jsonLast' keeps the last occurence of each key, using

217−-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.

218−--

219−-- @

220−-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))

221−-- @

222−--

223−-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using

224−-- 'fromListAccum'.

225−--

226−-- @

227−-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')

228−-- @

229−--

230−-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.

231−--

232−-- @

233−-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'

234−-- @

235−jsonWith :: ([(Text, Value)] -> Either String Object) -> Parser Value

236−jsonWith mkObject = fix $ \value_ -> do

161+-- In particular, be careful in using this function if you think your

162+-- code might interoperate with Javascript. A naïve Javascript

163+-- library that parses JSON data using @eval@ is vulnerable to attack

164+-- unless the encoded data represents an object or an array. JSON

165+-- implementations in other languages conform to that same restriction

166+-- to preserve interoperability and security.

167+value :: Parser Value

168+value = do

237169 skipSpace

238170 w <- A.peekWord8'

239171 case w of

240172 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)

241− OPEN_CURLY -> A.anyWord8 *> object_ mkObject value_

242− OPEN_SQUARE -> A.anyWord8 *> array_ value_

243− C_f -> string "false" $> Bool False

244− C_t -> string "true" $> Bool True

245− C_n -> string "null" $> Null

173+ OPEN_CURLY -> A.anyWord8 *> object_

174+ OPEN_SQUARE -> A.anyWord8 *> array_

175+ C_f -> string "false" *> pure (Bool False)

176+ C_t -> string "true" *> pure (Bool True)

177+ C_n -> string "null" *> pure Null

246178 _ | w >= 48 && w <= 57 || w == 45

247179 -> Number <$> scientific

248180 | otherwise -> fail "not a valid json value"

249−{-# INLINE jsonWith #-}

250−

251−-- | Variant of 'json' which keeps only the last occurence of every key.

252−jsonLast :: Parser Value

253−jsonLast = jsonWith (Right . H.fromListWith (const id))

254−

255−-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve

256−-- key-value pairs with the same keys.

257−jsonAccum :: Parser Value

258−jsonAccum = jsonWith (Right . fromListAccum)

259181

260−-- | Variant of 'json' which fails if any object contains duplicate keys.

261−jsonNoDup :: Parser Value

262−jsonNoDup = jsonWith parseListNoDup

263−

264−-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all

265−-- associated values from the original list @kvs@.

266−--

267−-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]

268−-- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]

269−fromListAccum :: [(Text, Value)] -> Object

270−fromListAccum =

271− fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)

272−

273−-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.

274−parseListNoDup :: [(Text, Value)] -> Either String Object

275−parseListNoDup =

276− H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just

277− where

278− unwrap k Nothing = Left $ "found duplicate key: " ++ show k

279− unwrap _ (Just v) = Right v

280−

281−-- | Strict version of 'value'. Synonym of 'json''.

182+-- | Strict version of 'value'. See also 'json''.

282183value' :: Parser Value

283−value' = jsonWith' (pure . H.fromList)

284−

285−-- | Strict version of 'jsonWith'.

286−jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value

287−jsonWith' mkObject = fix $ \value_ -> do

184+value' = do

288185 skipSpace

289186 w <- A.peekWord8'

290187 case w of

291188 DOUBLE_QUOTE -> do

292189 !s <- A.anyWord8 *> jstring_

293190 return (String s)

294− OPEN_CURLY -> A.anyWord8 *> object_' mkObject value_

295− OPEN_SQUARE -> A.anyWord8 *> array_' value_

296− C_f -> string "false" $> Bool False

297− C_t -> string "true" $> Bool True

298− C_n -> string "null" $> Null

191+ OPEN_CURLY -> A.anyWord8 *> object_'

192+ OPEN_SQUARE -> A.anyWord8 *> array_'

193+ C_f -> string "false" *> pure (Bool False)

194+ C_t -> string "true" *> pure (Bool True)

195+ C_n -> string "null" *> pure Null

299196 _ | w >= 48 && w <= 57 || w == 45

300197 -> do

301198 !n <- scientific

302199 return (Number n)

303200 | otherwise -> fail "not a valid json value"

304−{-# INLINE jsonWith' #-}

305−

306−-- | Variant of 'json'' which keeps only the last occurence of every key.

307−jsonLast' :: Parser Value

308−jsonLast' = jsonWith' (pure . H.fromListWith (const id))

309−

310−-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve

311−-- key-value pairs with the same keys.

312−jsonAccum' :: Parser Value

313−jsonAccum' = jsonWith' (pure . fromListAccum)

314−

315−-- | Variant of 'json'' which fails if any object contains duplicate keys.

316−jsonNoDup' :: Parser Value

317−jsonNoDup' = jsonWith' parseListNoDup

318201

319202-- | Parse a quoted JSON string.

320203jstring :: Parser Text

@@ -324,39 +207,21 @@ jstring = A.word8 DOUBLE_QUOTE *> jstring_

324207jstring_ :: Parser Text

325208{-# INLINE jstring_ #-}

326209jstring_ = {-# SCC "jstring_" #-} do

327−#if MIN_VERSION_ghc_prim(0,3,1)

328− (s, S _ escaped) <- A.runScanner startState go <* A.anyWord8

329− -- We escape only if there are

330− -- non-ascii (over 7bit) characters or backslash present.

331− --

332− -- Note: if/when text will have fast ascii -> text conversion

333− -- (e.g. uses utf8 encoding) we can have further speedup.

334− if isTrue# escaped

335− then case unescapeText s of

336− Right r -> return r

337− Left err -> fail $ show err

338− else return (TE.decodeUtf8 s)

339− where

340− startState = S 0# 0#

341− go (S skip escaped) (W8# c)

342− | isTrue# skip = Just (S 0# escaped')

343− | isTrue# (w ==# 34#) = Nothing -- double quote

344− | otherwise = Just (S skip' escaped')

345− where

346− w = word2Int# c

347− skip' = w ==# 92# -- backslash

348− escaped' = escaped

349− `orI#` (w `andI#` 0x80# ==# 0x80#) -- c >= 0x80

350− `orI#` skip'

351− `orI#` (w `andI#` 0x1f# ==# w) -- c < 0x20

352−

353−data S = S Int# Int#

354−#else

355210 s <- A.scan startState go <* A.anyWord8

356211 case unescapeText s of

357212 Right r -> return r

358213 Left err -> fail $ show err

359214 where

215+#if MIN_VERSION_ghc_prim(0,3,1)

216+ startState = S 0#

217+ go (S a) (W8# c)

218+ | isTrue# a = Just (S 0#)

219+ | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote

220+ | otherwise = let a' = word2Int# c ==# 92# -- backslash

221+ in Just (S a')

222+

223+data S = S Int#

224+#else

360225 startState = False

361226 go a c

362227 | a = Just False

@@ -390,12 +255,7 @@ eitherDecodeWith p to s =

390255 L.Done _ v -> case to v of

391256 ISuccess a -> Right a

392257 IError path msg -> Left (path, msg)

393− L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)

394− where

395− buildMsg :: [String] -> String -> String

396− buildMsg [] msg = msg

397− buildMsg (expectation:_) msg =

398− msg ++ ". Expecting " ++ expectation

258+ L.Fail _ _ msg -> Left ([], msg)

399259{-# INLINE eitherDecodeWith #-}

400260

401261eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

@@ -448,13 +308,14 @@ data SP = SP !Integer {-# UNPACK #-}!Int

448308

449309decimal0 :: Parser Integer

450310decimal0 = do

451− let zero = 48

311+ let step a w = a * 10 + fromIntegral (w - zero)

312+ zero = 48

452313 digits <- A.takeWhile1 isDigit_w8

453314 if B.length digits > 1 && B.unsafeHead digits == zero

454315 then fail "leading zero"

455− else return (bsToInteger digits)

316+ else return (B.foldl' step 0 digits)

456317

457−-- | Parse a JSON number.

318+{-# INLINE scientific #-}

458319scientific :: Parser Scientific

459320scientific = do

460321 let minus = 45

@@ -484,54 +345,3 @@ scientific = do

484345 (A.satisfy (\ex -> ex == littleE || ex == bigE) *>

485346 fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>

486347 return (Sci.scientific signedCoeff e)

487−{-# INLINE scientific #-}

488−

489−------------------ Copy-pasted and adapted from base ------------------------

490−

491−bsToInteger :: B.ByteString -> Integer

492−bsToInteger bs

493− | l > 40 = valInteger 10 l [ fromIntegral (w - 48) | w <- B.unpack bs ]

494− | otherwise = bsToIntegerSimple bs

495− where

496− l = B.length bs

497−

498−bsToIntegerSimple :: B.ByteString -> Integer

499−bsToIntegerSimple = B.foldl' step 0 where

500− step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'

501−

502−-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b

503−-- digits are combined into a single radix b^2 digit. This process is

504−-- repeated until we are left with a single digit. This algorithm

505−-- performs well only on large inputs, so we use the simple algorithm

506−-- for smaller inputs.

507−valInteger :: Integer -> Int -> [Integer] -> Integer

508−valInteger = go

509− where

510− go :: Integer -> Int -> [Integer] -> Integer

511− go _ _ [] = 0

512− go _ _ [d] = d

513− go b l ds

514− | l > 40 = b' `seq` go b' l' (combine b ds')

515− | otherwise = valSimple b ds

516− where

517− -- ensure that we have an even number of digits

518− -- before we call combine:

519− ds' = if even l then ds else 0 : ds

520− b' = b * b

521− l' = (l + 1) `quot` 2

522−

523− combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)

524− where

525− d = d1 * b + d2

526− combine _ [] = []

527− combine _ [_] = errorWithoutStackTrace "this should not happen"

528−

529−-- The following algorithm is only linear for types whose Num operations

530−-- are in constant time.

531−valSimple :: Integer -> [Integer] -> Integer

532−valSimple base = go 0

533− where

534− go r [] = r

535− go r (d : ds) = r' `seq` go r' ds

536− where

537− r' = r * base + fromIntegral d

Data/Aeson/Parser/Time.hs+103−18

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

1−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

4+-- |

5+-- Module: Data.Aeson.Parser.Time

7+-- License: BSD3

8+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

9+-- Stability: experimental

10+-- Portability: portable

11+--

12+-- Parsers for parsing dates and times.

213

314module Data.Aeson.Parser.Time

415 (

@@ -11,51 +22,123 @@ module Data.Aeson.Parser.Time

1122 , zonedTime

1223 ) where

1324

25+import Prelude ()

1426import Prelude.Compat

1527

16−import Data.Attoparsec.Text (Parser)

28+import Control.Applicative ((<|>))

29+import Control.Monad (void, when)

30+import Data.Aeson.Internal.Time (toPico)

31+import Data.Attoparsec.Text as A

32+import Data.Bits ((.&.))

33+import Data.Char (isDigit, ord)

34+import Data.Fixed (Pico)

35+import Data.Int (Int64)

36+import Data.Maybe (fromMaybe)

1737import Data.Text (Text)

18−import Data.Time.Calendar (Day)

38+import Data.Time.Calendar (Day, fromGregorianValid)

1939import Data.Time.Clock (UTCTime(..))

2040import qualified Data.Aeson.Types.Internal as Aeson

21−import qualified Data.Attoparsec.Text as A

22−import qualified Data.Attoparsec.Time as T

41+import qualified Data.Text as T

2342import qualified Data.Time.LocalTime as Local

2443

2544-- | Run an attoparsec parser as an aeson parser.

2645run :: Parser a -> Text -> Aeson.Parser a

27−run p t = case A.parseOnly (p <* A.endOfInput) t of

46+run p t = case A.parseOnly (p <* endOfInput) t of

2847 Left err -> fail $ "could not parse date: " ++ err

2948 Right r -> return r

3049

3150-- | Parse a date of the form @[+,-]YYYY-MM-DD@.

3251day :: Parser Day

33−day = T.day

34−{-# INLINE day #-}

52+day = do

53+ absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id

54+ y <- decimal <* char '-'

55+ m <- twoDigits <* char '-'

56+ d <- twoDigits

57+ maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)

58+

59+-- | Parse a two-digit integer (e.g. day of month, hour).

60+twoDigits :: Parser Int

61+twoDigits = do

62+ a <- digit

63+ b <- digit

64+ let c2d c = ord c .&. 15

65+ return $! c2d a * 10 + c2d b

3566

3667-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.

3768timeOfDay :: Parser Local.TimeOfDay

38−timeOfDay = T.timeOfDay

39−{-# INLINE timeOfDay #-}

69+timeOfDay = do

70+ h <- twoDigits

71+ m <- char ':' *> twoDigits

72+ s <- option 0 (char ':' *> seconds)

73+ if h < 24 && m < 60 && s < 61

74+ then return (Local.TimeOfDay h m s)

75+ else fail "invalid time"

76+

77+data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64

78+

79+-- | Parse a count of seconds, with the integer part being two digits

80+-- long.

81+seconds :: Parser Pico

82+seconds = do

83+ real <- twoDigits

84+ mc <- peekChar

85+ case mc of

86+ Just '.' -> do

87+ t <- anyChar *> takeWhile1 isDigit

88+ return $! parsePicos real t

89+ _ -> return $! fromIntegral real

90+ where

91+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))

92+ where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t

93+ step ma@(T m a) c

94+ | m <= 0 = ma

95+ | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)

4096

4197-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

4298-- zero. (This makes some speedups possible.)

4399timeZone :: Parser (Maybe Local.TimeZone)

44−timeZone = T.timeZone

45−{-# INLINE timeZone #-}

100+timeZone = do

101+ let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)

102+ maybeSkip ' '

103+ ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'

104+ if ch == 'Z'

105+ then return Nothing

106+ else do

107+ h <- twoDigits

108+ mm <- peekChar

109+ m <- case mm of

110+ Just ':' -> anyChar *> twoDigits

111+ Just d | isDigit d -> twoDigits

112+ _ -> return 0

113+ let off | ch == '-' = negate off0

114+ | otherwise = off0

115+ off0 = h * 60 + m

116+ case undefined of

117+ _ | off == 0 ->

118+ return Nothing

119+ | off < -720 || off > 840 || m > 59 ->

120+ fail "invalid time zone offset"

121+ | otherwise ->

122+ let !tz = Local.minutesToTimeZone off

123+ in return (Just tz)

46124

47125-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.

48126-- The space may be replaced with a @T@. The number of seconds is optional

49127-- and may be followed by a fractional component.

50128localTime :: Parser Local.LocalTime

51−localTime = T.localTime

52−{-# INLINE localTime #-}

129+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay

130+ where daySep = satisfy (\c -> c == 'T' || c == ' ')

53131

54132-- | Behaves as 'zonedTime', but converts any time zone offset into a

55133-- UTC time.

56134utcTime :: Parser UTCTime

57−utcTime = T.utcTime

58−{-# INLINE utcTime #-}

135+utcTime = do

136+ lt@(Local.LocalTime d t) <- localTime

137+ mtz <- timeZone

138+ case mtz of

139+ Nothing -> let !tt = Local.timeOfDayToTime t

140+ in return (UTCTime d tt)

141+ Just tz -> return $! Local.localTimeToUTC tz lt

59142

60143-- | Parse a date with time zone info. Acceptable formats:

61144--

@@ -69,5 +152,7 @@ utcTime = T.utcTime

69152-- two digits are hours, the @:@ is optional and the second two digits

70153-- (also optional) are minutes.

71154zonedTime :: Parser Local.ZonedTime

72−zonedTime = T.zonedTime

73−{-# INLINE zonedTime #-}

155+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

156+

157+utc :: Local.TimeZone

158+utc = Local.TimeZone 0 False ""

Data/Aeson/Parser/Unescape.hs+51−11

@@ -1,11 +1,51 @@

1−{-# LANGUAGE CPP #-}

2−module Data.Aeson.Parser.Unescape

3− (

4− unescapeText

5− ) where

6−

7−#ifdef CFFI

8−import Data.Aeson.Parser.UnescapeFFI (unescapeText)

9−#else

10−import Data.Aeson.Parser.UnescapePure (unescapeText)

11−#endif

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE MagicHash #-}

3+{-# LANGUAGE UnliftedFFITypes #-}

5+module Data.Aeson.Parser.Unescape (

6+ unescapeText

7+) where

9+import Control.Exception (evaluate, throw, try)

10+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)

11+import Data.ByteString as B

12+import Data.ByteString.Internal as B hiding (c2w)

13+import qualified Data.Text.Array as A

14+import Data.Text.Encoding.Error (UnicodeException (..))

15+import Data.Text.Internal (Text (..))

16+import Data.Text.Internal.Private (runText)

17+import Data.Text.Unsafe (unsafeDupablePerformIO)

18+import Data.Word (Word8)

19+import Foreign.C.Types (CInt (..), CSize (..))

20+import Foreign.ForeignPtr (withForeignPtr)

21+import Foreign.Marshal.Utils (with)

22+import Foreign.Ptr (Ptr, plusPtr)

23+import Foreign.Storable (peek)

24+import GHC.Base (MutableByteArray#)

25+

26+foreign import ccall unsafe "_js_decode_string" c_js_decode

27+ :: MutableByteArray# s -> Ptr CSize

28+ -> Ptr Word8 -> Ptr Word8 -> IO CInt

29+

30+unescapeText' :: ByteString -> Text

31+unescapeText' (PS fp off len) = runText $ \done -> do

32+ let go dest = withForeignPtr fp $ \ptr ->

33+ with (0::CSize) $ \destOffPtr -> do

34+ let end = ptr `plusPtr` (off + len)

35+ loop curPtr = do

36+ res <- c_js_decode (A.maBA dest) destOffPtr curPtr end

37+ case res of

38+ 0 -> do

39+ n <- peek destOffPtr

40+ unsafeSTToIO (done dest (fromIntegral n))

41+ _ ->

42+ throw (DecodeError desc Nothing)

43+ loop (ptr `plusPtr` off)

44+ (unsafeIOToST . go) =<< A.new len

45+ where

46+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"

47+{-# INLINE unescapeText' #-}

48+

49+unescapeText :: ByteString -> Either UnicodeException Text

50+unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'

51+{-# INLINE unescapeText #-}

Data/Aeson/QQ/Simple.hsdeleted−25

@@ -1,25 +0,0 @@

1−-- | Like "Data.Aeson.QQ" but without interpolation.

2−module Data.Aeson.QQ.Simple (aesonQQ) where

3−

4−import Data.Aeson

5−import qualified Data.Text as T

6−import qualified Data.Text.Encoding as TE

7−import Language.Haskell.TH

8−import Language.Haskell.TH.Quote

9−import Language.Haskell.TH.Syntax (Lift (..))

10−import Prelude ()

11−import Prelude.Compat

12−

13−aesonQQ :: QuasiQuoter

14−aesonQQ = QuasiQuoter

15− { quoteExp = aesonExp

16− , quotePat = const $ error "No quotePat defined for jsonQQ"

17− , quoteType = const $ error "No quoteType defined for jsonQQ"

18− , quoteDec = const $ error "No quoteDec defined for jsonQQ"

19− }

20−

21−aesonExp :: String -> ExpQ

22−aesonExp txt =

23− case eitherDecodeStrict $ TE.encodeUtf8 $ T.pack txt of

24− Left err -> error $ "Error in aesonExp: " ++ show err

25− Right val -> lift (val :: Value)

Data/Aeson/TH.hs+896−445

@@ -85,6 +85,7 @@ $('deriveJSON' 'defaultOptions' ''(,,,))

8585@

8686

8787-}

88+

8889module Data.Aeson.TH

8990 (

9091 -- * Encoding configuration

@@ -116,42 +117,49 @@ module Data.Aeson.TH

116117 , mkLiftParseJSON2

117118 ) where

118119

119−import Prelude.Compat

120+import Prelude ()

121+import Prelude.Compat hiding (exp)

120122

121123import Control.Applicative ((<|>))

122−import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))

124+import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))

123125import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)

124−import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))

126+import Data.Aeson.Types.Internal ((<?>), Pair, JSONPathElement(Key))

125127import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)

126−import Data.Aeson.Types.ToJSON (fromPairs, pair)

127128import Control.Monad (liftM2, unless, when)

128129import Data.Foldable (foldr')

129130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)

130131import Data.List (nub)

131132#endif

132−import Data.List (foldl', genericLength, intercalate, partition, union)

133+import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)

133134import Data.List.NonEmpty ((<|), NonEmpty((:|)))

134135import Data.Map (Map)

135136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

136−import qualified Data.Monoid as Monoid

137137import Data.Set (Set)

138+#if MIN_VERSION_template_haskell(2,8,0)

138139import Language.Haskell.TH hiding (Arity)

139−import Language.Haskell.TH.Datatype

140+#else

141+import Language.Haskell.TH

142+#endif

143+import Language.Haskell.TH.Syntax (VarStrictType)

144+#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))

145+import Language.Haskell.TH.Lib (starK)

146+#endif

140147#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

141148import Language.Haskell.TH.Syntax (mkNameG_tc)

142149#endif

143150import Text.Printf (printf)

151+import qualified Data.Aeson as A

144152import qualified Data.Aeson.Encoding.Internal as E

145153import qualified Data.Foldable as F (all)

146−import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)

147−import qualified Data.List.NonEmpty as NE (length, reverse)

148−import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

149−import qualified Data.Semigroup as Semigroup (Option(..))

154+import qualified Data.HashMap.Strict as H (lookup, toList)

155+import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)

156+import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)

150157import qualified Data.Set as Set (empty, insert, member)

151158import qualified Data.Text as T (Text, pack, unpack)

152−import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)

159+import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)

153160import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)

154161

162+

155163--------------------------------------------------------------------------------

156164-- Convenience

157165--------------------------------------------------------------------------------

@@ -245,8 +253,8 @@ deriveToJSONCommon :: JSONClass

245253 -> Name

246254 -- ^ Name of the type for which to generate an instance.

247255 -> Q [Dec]

248−deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue Value jc)

249− , (ToEncoding, \jc _ -> consToValue Encoding jc)

256+deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue jc)

257+ , (ToEncoding, \jc _ -> consToEncoding jc)

250258 ]

251259

252260-- | Generates a lambda expression which encodes the given data type or

@@ -276,7 +284,7 @@ mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.

276284 -> Options -- ^ Encoding options.

277285 -> Name -- ^ Name of the encoded type.

278286 -> Q Exp

279−mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)

287+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)

280288

281289-- | Generates a lambda expression which encodes the given data type or

282290-- data family instance constructor as a JSON string.

@@ -305,272 +313,413 @@ mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.

305313 -> Options -- ^ Encoding options.

306314 -> Name -- ^ Name of the encoded type.

307315 -> Q Exp

308−mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)

316+mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)

309317

310318-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates

311−-- code to generate a 'Value' or 'Encoding' of a number of constructors. All

312−-- constructors must be from the same type.

313−consToValue :: ToJSONFun

314− -- ^ The method ('toJSON' or 'toEncoding') being derived.

315− -> JSONClass

319+-- code to generate a 'Value' of a number of constructors. All constructors

320+-- must be from the same type.

321+consToValue :: JSONClass

316322 -- ^ The ToJSON variant being derived.

317323 -> Options

318324 -- ^ Encoding options.

319− -> [Type]

320− -- ^ The types from the data type/data family instance declaration

321− -> [ConstructorInfo]

325+ -> [Con]

322326 -- ^ Constructors for which to generate JSON generating code.

323327 -> Q Exp

324328

325−consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "

326− ++ "Not a single constructor given!"

329+consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "

330+ ++ "Not a single constructor given!"

327331

328−consToValue target jc opts instTys cons = do

332+consToValue jc opts cons = do

329333 value <- newName "value"

330334 tjs <- newNameList "_tj" $ arityInt jc

331335 tjls <- newNameList "_tjl" $ arityInt jc

332336 let zippedTJs = zip tjs tjls

333337 interleavedTJs = interleave tjs tjls

334− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys

335− tvMap = M.fromList $ zip lastTyVars zippedTJs

336338 lamE (map varP $ interleavedTJs ++ [value]) $

337− caseE (varE value) (matches tvMap)

339+ caseE (varE value) (matches zippedTJs)

338340 where

339− matches tvMap = case cons of

341+ matches tjs = case cons of

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

341343 -- forgotten.

342− [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]

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

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

344− [ match (conP conName []) (normalB $ conStr target opts conName) []

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

345347 | con <- cons

346− , let conName = constructorName con

348+ , let conName = getConName con

347349 ]

348− | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]

350+ | otherwise -> [argsToValue jc tjs opts True con | con <- cons]

349351

350−-- | Name of the constructor as a quoted 'Value' or 'Encoding'.

351−conStr :: ToJSONFun -> Options -> Name -> Q Exp

352−conStr Value opts = appE [|String|] . conTxt opts

353−conStr Encoding opts = appE [|E.text|] . conTxt opts

352+conStr :: Options -> Name -> Q Exp

353+conStr opts = appE [|String|] . conTxt opts

354354

355−-- | Name of the constructor as a quoted 'Text'.

356355conTxt :: Options -> Name -> Q Exp

357−conTxt opts = appE [|T.pack|] . stringE . conString opts

356+conTxt opts = appE [|T.pack|] . conStringE opts

357+

358+conStringE :: Options -> Name -> Q Exp

359+conStringE opts = stringE . constructorTagModifier opts . nameBase

360+

361+-- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates

362+-- code to write out a value for a number of constructors. All constructors

363+-- must be from the same type.

364+consToEncoding :: JSONClass

365+ -- ^ The ToJSON variant being derived.

366+ -> Options

367+ -- ^ Encoding options.

368+ -> [Con]

369+ -- ^ Constructors for which to generate JSON generating code.

370+ -> Q Exp

371+

372+consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "

373+ ++ "Not a single constructor given!"

374+

375+consToEncoding jc opts cons = do

376+ value <- newName "value"

377+ tes <- newNameList "_te" $ arityInt jc

378+ tels <- newNameList "_tel" $ arityInt jc

379+ let zippedTEs = zip tes tels

380+ interleavedTEs = interleave tes tels

381+ lamE (map varP $ interleavedTEs ++ [value]) $

382+ caseE (varE value) (matches zippedTEs)

383+ where

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]

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

391+ [ match (conP conName [])

392+ (normalB $ encStr opts conName) []

393+ | con <- cons

394+ , let conName = getConName con

395+ ]

396+ | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]

358397

359−-- | Name of the constructor.

360−conString :: Options -> Name -> String

361−conString opts = constructorTagModifier opts . nameBase

398+encStr :: Options -> Name -> Q Exp

399+encStr opts = appE [|E.text|] . conTxt opts

362400

363401-- | If constructor is nullary.

364−isNullary :: ConstructorInfo -> Bool

365−isNullary ConstructorInfo { constructorVariant = NormalConstructor

366− , constructorFields = tys } = null tys

402+isNullary :: Con -> Bool

403+isNullary (NormalC _ []) = True

367404isNullary _ = False

368405

369−-- | Wrap fields of a non-record constructor. See 'sumToValue'.

370−opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

371−opaqueSumToValue target opts multiCons nullary conName value =

372− sumToValue target opts multiCons nullary conName

373− value

374− pairs

375− where

376− pairs contentsFieldName = pairE contentsFieldName value

377−

378−-- | Wrap fields of a record constructor. See 'sumToValue'.

379−recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

380−recordSumToValue target opts multiCons nullary conName pairs =

381− sumToValue target opts multiCons nullary conName

382− (fromPairsE pairs)

383− (const pairs)

384−

385−-- | Wrap fields of a constructor.

386−sumToValue

387− :: ToJSONFun

388− -- ^ The method being derived.

389− -> Options

390− -- ^ Deriving options.

391− -> Bool

392− -- ^ Does this type have multiple constructors.

393− -> Bool

394− -- ^ Is this constructor nullary.

395− -> Name

396− -- ^ Constructor name.

397− -> ExpQ

398− -- ^ Fields of the constructor as a 'Value' or 'Encoding'.

399− -> (String -> ExpQ)

400− -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'

401− -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method

402− -- being derived.

403− --

404− -- - For non-records, produces a pair @"contentsFieldName":value@,

405− -- given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.

406− -- - For records, produces the list of pairs corresponding to fields of the

407− -- encoded value (ignores the argument). See 'recordSumToValue'.

408− -> ExpQ

409−sumToValue target opts multiCons nullary conName value pairs

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

407+sumToValue opts multiCons conName exp

410408 | multiCons =

411409 case sumEncoding opts of

412410 TwoElemArray ->

413− array target [conStr target opts conName, value]

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

414412 TaggedObject{tagFieldName, contentsFieldName} ->

415− -- TODO: Maybe throw an error in case

416− -- tagFieldName overwrites a field in pairs.

417− let tag = pairE tagFieldName (conStr target opts conName)

418− content = pairs contentsFieldName

419− in fromPairsE $

420− if nullary then tag else infixApp tag [|(Monoid.<>)|] content

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

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

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

416+ ]

421417 ObjectWithSingleField ->

422− objectE [(conString opts conName, value)]

423− UntaggedValue | nullary -> conStr target opts conName

424− UntaggedValue -> value

425− | otherwise = value

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

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

420+ ]

421+ UntaggedValue -> exp

422+ | otherwise = exp

423+

424+nullarySumToValue :: Options -> Bool -> Name -> Q Exp

425+nullarySumToValue opts multiCons conName =

426+ case sumEncoding opts of

427+ TaggedObject{tagFieldName} ->

428+ [|A.object|] `appE` listE

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

430+ ]

431+ UntaggedValue -> conStr opts conName

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

426433

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

428−argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

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

436+-- Nullary constructors. Generates code that explicitly matches against the

437+-- constructor even though it doesn't contain data. This is useful to prevent

438+-- type errors.

439+argsToValue jc tjs opts multiCons (NormalC conName []) = do

440+ ([], _) <- reifyConTys jc tjs conName

441+ match (conP conName [])

442+ (normalB (nullarySumToValue opts multiCons conName))

443+ []

429444

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

431−argsToValue target jc tvMap opts multiCons

432− ConstructorInfo { constructorName = conName

433− , constructorVariant = NormalConstructor

434− , constructorFields = argTys } = do

435− argTys' <- mapM resolveTypeSynonyms argTys

436− let len = length argTys'

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

447+ (argTys, tvMap) <- reifyConTys jc tjs conName

448+ let len = length ts

437449 args <- newNameList "arg" len

438− let js = case [ dispatchToJSON target jc conName tvMap argTy

439− `appE` varE arg

440− | (arg, argTy) <- zip args argTys'

441− ] of

442− -- Single argument is directly converted.

443− [e] -> e

444− -- Zero and multiple arguments are converted to a JSON array.

445− es -> array target es

446−

450+ js <- case [ dispatchToJSON jc conName tvMap argTy

451+ `appE` varE arg

452+ | (arg, argTy) <- zip args argTys

453+ ] of

454+ -- Single argument is directly converted.

455+ [e] -> return e

456+ -- Multiple arguments are converted to a JSON array.

457+ es -> do

458+ mv <- newName "mv"

459+ let newMV = bindS (varP mv)

460+ ([|VM.unsafeNew|] `appE`

461+ litE (integerL $ fromIntegral len))

462+ stmts = [ noBindS $

463+ [|VM.unsafeWrite|] `appE`

464+ varE mv `appE`

465+ litE (integerL ix) `appE`

466+ e

467+ | (ix, e) <- zip [(0::Integer)..] es

468+ ]

469+ ret = noBindS $ [|return|] `appE` varE mv

470+ return $ [|Array|] `appE`

471+ (varE 'V.create `appE`

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

447473 match (conP conName $ map varP args)

448− (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)

474+ (normalB $ sumToValue opts multiCons conName js)

449475 []

450476

451477-- Records.

452−argsToValue target jc tvMap opts multiCons

453− info@ConstructorInfo { constructorName = conName

454− , constructorVariant = RecordConstructor fields

455− , constructorFields = argTys } =

456− case (unwrapUnaryRecords opts, not multiCons, argTys) of

457− (True,True,[_]) -> argsToValue target jc tvMap opts multiCons

458− (info{constructorVariant = NormalConstructor})

459− _ -> do

460− argTys' <- mapM resolveTypeSynonyms argTys

461− args <- newNameList "arg" $ length argTys'

462− let pairs | omitNothingFields opts = infixApp maybeFields

463− [|(Monoid.<>)|]

464− restFields

465− | otherwise = mconcatE (map pureToPair argCons)

466−

467− argCons = zip3 (map varE args) argTys' fields

468−

469− maybeFields = mconcatE (map maybeToPair maybes)

470−

471− restFields = mconcatE (map pureToPair rest)

472−

473− (maybes0, rest0) = partition isMaybe argCons

474− (options, rest) = partition isOption rest0

475− maybes = maybes0 ++ map optionToMaybe options

476−

477− maybeToPair = toPairLifted True

478− pureToPair = toPairLifted False

479−

480− toPairLifted lifted (arg, argTy, field) =

481− let toValue = dispatchToJSON target jc conName tvMap argTy

482− fieldName = fieldLabel opts field

483− e arg' = pairE fieldName (toValue `appE` arg')

484− in if lifted

485− then do

486− x <- newName "x"

487− [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg

488− else e arg

489−

490− match (conP conName $ map varP args)

491− (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)

492− []

478+argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of

479+ (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])

480+ _ -> do

481+ (argTys, tvMap) <- reifyConTys jc tjs conName

482+ args <- newNameList "arg" $ length ts

483+ let exp = [|A.object|] `appE` pairs

484+

485+ pairs | omitNothingFields opts = infixApp maybeFields

486+ [|(++)|]

487+ restFields

488+ | otherwise = listE $ map toPair argCons

489+

490+ argCons = zip3 args argTys ts

491+

492+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

493+

494+ restFields = listE $ map toPair rest

495+

496+ (maybes, rest) = partition isMaybe argCons

497+

498+ maybeToPair (arg, argTy, (field, _, _)) =

499+ infixApp ([|keyValuePairWith|]

500+ `appE` dispatchToJSON jc conName tvMap argTy

501+ `appE` toFieldName field)

502+ [|(<$>)|]

503+ (varE arg)

504+

505+ toPair (arg, argTy, (field, _, _)) =

506+ [|keyValuePairWith|]

507+ `appE` dispatchToJSON jc conName tvMap argTy

508+ `appE` toFieldName field

509+ `appE` varE arg

510+

511+ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field

512+

513+ match (conP conName $ map varP args)

514+ ( normalB

515+ $ if multiCons

516+ then case sumEncoding opts of

517+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]

518+ TaggedObject{tagFieldName} ->

519+ [|A.object|] `appE`

520+ -- TODO: Maybe throw an error in case

521+ -- tagFieldName overwrites a field in pairs.

522+ infixApp (infixApp [|T.pack tagFieldName|]

523+ [|(.=)|]

524+ (conStr opts conName))

525+ [|(:)|]

526+ pairs

527+ ObjectWithSingleField ->

528+ [|A.object|] `appE` listE

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

530+ UntaggedValue -> exp

531+ else exp

532+ ) []

493533

494534-- Infix constructors.

495−argsToValue target jc tvMap opts multiCons

496− ConstructorInfo { constructorName = conName

497− , constructorVariant = InfixConstructor

498− , constructorFields = argTys } = do

499− [alTy, arTy] <- mapM resolveTypeSynonyms argTys

535+argsToValue jc tjs opts multiCons (InfixC _ conName _) = do

536+ ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName

500537 al <- newName "argL"

501538 ar <- newName "argR"

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

503540 ( normalB

504− $ opaqueSumToValue target opts multiCons False conName

505− $ array target

506− [ dispatchToJSON target jc conName tvMap aTy

507− `appE` varE a

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

509− ]

541+ $ sumToValue opts multiCons conName

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

543+ `appE` varE a

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

545+ ]

510546 )

511547 []

548+-- Existentially quantified constructors.

549+argsToValue jc tjs opts multiCons (ForallC _ _ con) =

550+ argsToValue jc tjs opts multiCons con

512551

513−isMaybe :: (a, Type, b) -> Bool

514−isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe

515−isMaybe _ = False

552+#if MIN_VERSION_template_haskell(2,11,0)

553+-- GADTs.

554+argsToValue jc tjs opts multiCons (GadtC conNames ts _) =

555+ argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts

516556

517−isOption :: (a, Type, b) -> Bool

518−isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option

519−isOption _ = False

557+argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =

558+ argsToValue jc tjs opts multiCons $ RecC (head conNames) ts

559+#endif

520560

521−optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)

522−optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)

561+isMaybe :: (a, b, (c, d, Type)) -> Bool

562+isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe

563+isMaybe _ = False

523564

524565(<^>) :: ExpQ -> ExpQ -> ExpQ

525566(<^>) a b = infixApp a [|(E.><)|] b

526567infixr 6 <^>

527568

569+(<:>) :: ExpQ -> ExpQ -> ExpQ

570+(<:>) a b = a <^> [|E.colon|] <^> b

571+infixr 5 <:>

572+

528573(<%>) :: ExpQ -> ExpQ -> ExpQ

529574(<%>) a b = a <^> [|E.comma|] <^> b

530575infixr 4 <%>

531576

532−-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').

533−array :: ToJSONFun -> [ExpQ] -> ExpQ

534−array Encoding [] = [|E.emptyArray_|]

535−array Value [] = [|Array V.empty|]

536−array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es

537−array Value es = do

538− mv <- newName "mv"

539− let newMV = bindS (varP mv)

540− ([|VM.unsafeNew|] `appE`

541− litE (integerL $ fromIntegral (length es)))

542− stmts = [ noBindS $

543− [|VM.unsafeWrite|] `appE`

544− varE mv `appE`

545− litE (integerL ix) `appE`

546− e

547− | (ix, e) <- zip [(0::Integer)..] es

548− ]

549− ret = noBindS $ [|return|] `appE` varE mv

550− [|Array|] `appE`

551− (varE 'V.create `appE`

552− doE (newMV:stmts++[ret]))

577+array :: ExpQ -> ExpQ

578+array exp = [|E.wrapArray|] `appE` exp

553579

554−-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.

555−objectE :: [(String, ExpQ)] -> ExpQ

556−objectE = fromPairsE . mconcatE . fmap (uncurry pairE)

580+object :: ExpQ -> ExpQ

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

557582

558−-- | 'mconcat' a list of fixed length.

559−--

560−-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]

561−mconcatE :: [ExpQ] -> ExpQ

562−mconcatE [] = [|Monoid.mempty|]

563−mconcatE [x] = x

564−mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)

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

584+sumToEncoding opts multiCons conName exp

585+ | multiCons =

586+ let fexp = exp in

587+ case sumEncoding opts of

588+ TwoElemArray ->

589+ array (encStr opts conName <%> fexp)

590+ TaggedObject{tagFieldName, contentsFieldName} ->

591+ object $

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

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

594+ ObjectWithSingleField ->

595+ object (encStr opts conName <:> fexp)

596+ UntaggedValue -> exp

597+ | otherwise = exp

598+

599+nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp

600+nullarySumToEncoding opts multiCons conName =

601+ case sumEncoding opts of

602+ TaggedObject{tagFieldName} ->

603+ object $

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

605+ UntaggedValue -> encStr opts conName

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

565607

566−fromPairsE :: ExpQ -> ExpQ

567−fromPairsE = ([|fromPairs|] `appE`)

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

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

610+-- Nullary constructors. Generates code that explicitly matches against the

611+-- constructor even though it doesn't contain data. This is useful to prevent

612+-- type errors.

613+argsToEncoding jc tes opts multiCons (NormalC conName []) = do

614+ ([], _) <- reifyConTys jc tes conName

615+ match (conP conName [])

616+ (normalB (nullarySumToEncoding opts multiCons conName))

617+ []

568618

569−-- | Create (an encoding of) a key-value pair.

570−--

571−-- > pairE "k" [|v|] = [|pair "k" v|]

572−pairE :: String -> ExpQ -> ExpQ

573−pairE k v = [|pair k|] `appE` v

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

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

621+ (argTys, tvMap) <- reifyConTys jc tes conName

622+ let len = length ts

623+ args <- newNameList "arg" len

624+ js <- case zip args argTys of

625+ -- Single argument is directly converted.

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

627+ `appE` varE e)

628+ -- Multiple arguments are converted to a JSON array.

629+ es ->

630+ return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy

631+ `appE` varE x

632+ | (x,xTy) <- es

633+ ]))

634+ match (conP conName $ map varP args)

635+ (normalB $ sumToEncoding opts multiCons conName js)

636+ []

637+

638+-- Records.

639+argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of

640+ (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])

641+ _ -> do

642+ args <- newNameList "arg" $ length ts

643+ (argTys, tvMap) <- reifyConTys jc tes conName

644+ let exp = object objBody

645+

646+ objBody = [|E.econcat|] `appE`

647+ ([|intersperse E.comma|] `appE` pairs)

648+ pairs | omitNothingFields opts = infixApp maybeFields

649+ [|(++)|]

650+ restFields

651+ | otherwise = listE (map toPair argCons)

652+

653+ argCons = zip3 args argTys ts

654+

655+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)

656+

657+ restFields = listE (map toPair rest)

658+

659+ (maybes, rest) = partition isMaybe argCons

660+

661+ maybeToPair (arg, argTy, (field, _, _)) =

662+ infixApp

663+ (infixApp

664+ (infixE

665+ (Just $ toFieldName field <^> [|E.colon|])

666+ [|(E.><)|]

667+ Nothing)

668+ [|(.)|]

669+ (dispatchToEncoding jc conName tvMap argTy))

670+ [|(<$>)|]

671+ (varE arg)

672+

673+ toPair (arg, argTy, (field, _, _)) =

674+ toFieldName field

675+ <:> dispatchToEncoding jc conName tvMap argTy

676+ `appE` varE arg

677+

678+ toFieldName field = [|E.text|] `appE`

679+ ([|T.pack|] `appE` fieldLabelExp opts field)

680+

681+ match (conP conName $ map varP args)

682+ ( normalB

683+ $ if multiCons

684+ then case sumEncoding opts of

685+ TwoElemArray -> array $

686+ encStr opts conName <%> exp

687+ TaggedObject{tagFieldName} -> object $

688+ ([|E.text (T.pack tagFieldName)|] <:>

689+ encStr opts conName) <%>

690+ objBody

691+ ObjectWithSingleField -> object $

692+ encStr opts conName <:> exp

693+ UntaggedValue -> exp

694+ else exp

695+ ) []

696+

697+-- Infix constructors.

698+argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do

699+ al <- newName "argL"

700+ ar <- newName "argR"

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

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

703+ ( normalB

704+ $ sumToEncoding opts multiCons conName

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

706+ `appE` varE a

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

708+ ])

709+ )

710+ []

711+-- Existentially quantified constructors.

712+argsToEncoding jc tes opts multiCons (ForallC _ _ con) =

713+ argsToEncoding jc tes opts multiCons con

714+

715+#if MIN_VERSION_template_haskell(2,11,0)

716+-- GADTs.

717+argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =

718+ argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts

719+

720+argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =

721+ argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts

722+#endif

574723

575724--------------------------------------------------------------------------------

576725-- FromJSON

@@ -654,41 +803,31 @@ consFromJSON :: JSONClass

654803 -- ^ Name of the type to which the constructors belong.

655804 -> Options

656805 -- ^ Encoding options

657− -> [Type]

658− -- ^ The types from the data type/data family instance declaration

659− -> [ConstructorInfo]

806+ -> [Con]

660807 -- ^ Constructors for which to generate JSON parsing code.

661808 -> Q Exp

662809

663−consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

664− ++ "Not a single constructor given!"

810+consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

811+ ++ "Not a single constructor given!"

665812

666−consFromJSON jc tName opts instTys cons = do

813+consFromJSON jc tName opts cons = do

667814 value <- newName "value"

668815 pjs <- newNameList "_pj" $ arityInt jc

669816 pjls <- newNameList "_pjl" $ arityInt jc

670817 let zippedPJs = zip pjs pjls

671818 interleavedPJs = interleave pjs pjls

672− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys

673− tvMap = M.fromList $ zip lastTyVars zippedPJs

674− lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

819+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs

675820

676821 where

677− checkExi tvMap con = checkExistentialContext jc tvMap

678− (constructorContext con)

679− (constructorName con)

680−

681− lamExpr value tvMap = case cons of

682− [con]

683− | not (tagSingleConstructors opts)

684− -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)

822+ lamExpr value pjs = case cons of

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

685824 _ | sumEncoding opts == UntaggedValue

686− -> parseUntaggedValue tvMap cons value

825+ -> parseUntaggedValue pjs cons value

687826 | otherwise

688827 -> caseE (varE value) $

689828 if allNullaryToStringTag opts && all isNullary cons

690829 then allNullaryMatches

691− else mixedMatches tvMap

830+ else mixedMatches pjs

692831

693832 allNullaryMatches =

694833 [ do txt <- newName "txt"

@@ -697,11 +836,12 @@ consFromJSON jc tName opts instTys cons = do

697836 [ liftM2 (,) (normalG $

698837 infixApp (varE txt)

699838 [|(==)|]

700− (conTxt opts conName)

839+ ([|T.pack|] `appE`

840+ conStringE opts conName)

701841 )

702842 ([|pure|] `appE` conE conName)

703843 | con <- cons

704− , let conName = constructorName con

844+ , let conName = getConName con

705845 ]

706846 ++

707847 [ liftM2 (,)

@@ -722,13 +862,13 @@ consFromJSON jc tName opts instTys cons = do

722862 []

723863 ]

724864

725− mixedMatches tvMap =

865+ mixedMatches pjs =

726866 case sumEncoding opts of

727867 TaggedObject {tagFieldName, contentsFieldName} ->

728− parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName

868+ parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName

729869 UntaggedValue -> error "UntaggedValue: Should be handled already"

730870 ObjectWithSingleField ->

731− parseObject $ parseObjectWithSingleField tvMap

871+ parseObject $ parseObjectWithSingleField pjs

732872 TwoElemArray ->

733873 [ do arr <- newName "array"

734874 match (conP 'Array [varP arr])

@@ -736,7 +876,7 @@ consFromJSON jc tName opts instTys cons = do

736876 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)

737877 [|(==)|]

738878 (litE $ integerL 2))

739− (parse2ElemArray tvMap arr)

879+ (parse2ElemArray pjs arr)

740880 , liftM2 (,) (normalG [|otherwise|])

741881 ([|not2ElemArray|]

742882 `appE` litE (stringL $ show tName)

@@ -767,29 +907,25 @@ consFromJSON jc tName opts instTys cons = do

767907 []

768908 ]

769909

770− parseTaggedObject tvMap typFieldName valFieldName obj = do

910+ parseTaggedObject pjs typFieldName valFieldName obj = do

771911 conKey <- newName "conKey"

772912 doE [ bindS (varP conKey)

773913 (infixApp (varE obj)

774914 [|(.:)|]

775915 ([|T.pack|] `appE` stringE typFieldName))

776− , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject

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

777917 ]

778918

779− parseUntaggedValue tvMap cons' conVal =

919+ parseUntaggedValue pjs cons' conVal =

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

781− (map (\x -> parseValue tvMap x conVal) cons')

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

782922

783− parseValue _tvMap

784− ConstructorInfo { constructorName = conName

785− , constructorVariant = NormalConstructor

786− , constructorFields = [] }

787− conVal = do

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

788924 str <- newName "str"

789925 caseE (varE conVal)

790926 [ match (conP 'String [varP str])

791927 (guardedB

792− [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)

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

793929 )

794930 ([|pure|] `appE` conE conName)

795931 ]

@@ -797,11 +933,11 @@ consFromJSON jc tName opts instTys cons = do

797933 []

798934 , matchFailed tName conName "String"

799935 ]

800− parseValue tvMap con conVal =

801− checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)

936+ parseValue pjs con conVal =

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

802938

803939

804− parse2ElemArray tvMap arr = do

940+ parse2ElemArray pjs arr = do

805941 conKey <- newName "conKey"

806942 conVal <- newName "conVal"

807943 let letIx n ix =

@@ -816,7 +952,7 @@ consFromJSON jc tName opts instTys cons = do

816952 (caseE (varE conKey)

817953 [ do txt <- newName "txt"

818954 match (conP 'String [varP txt])

819− (normalB $ parseContents tvMap

955+ (normalB $ parseContents pjs

820956 txt

821957 (Right conVal)

822958 'conNotFoundFail2ElemArray

@@ -833,12 +969,12 @@ consFromJSON jc tName opts instTys cons = do

833969 ]

834970 )

835971

836− parseObjectWithSingleField tvMap obj = do

972+ parseObjectWithSingleField pjs obj = do

837973 conKey <- newName "conKey"

838974 conVal <- newName "conVal"

839975 caseE ([e|H.toList|] `appE` varE obj)

840976 [ match (listP [tupP [varP conKey, varP conVal]])

841− (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)

977+ (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)

842978 []

843979 , do other <- newName "other"

844980 match (varP other)

@@ -849,7 +985,7 @@ consFromJSON jc tName opts instTys cons = do

849985 []

850986 ]

851987

852− parseContents tvMap conKey contents errorFun =

988+ parseContents pjs conKey contents errorFun =

853989 caseE (varE conKey)

854990 [ match wildP

855991 ( guardedB $

@@ -857,8 +993,7 @@ consFromJSON jc tName opts instTys cons = do

857993 [|(==)|]

858994 ([|T.pack|] `appE`

859995 conNameExp opts con)

860− e <- checkExi tvMap con $

861− parseArgs jc tvMap tName opts con contents

996+ e <- parseArgs jc pjs tName opts con contents

862997 return (g, e)

863998 | con <- cons

864999 ]

@@ -871,7 +1006,7 @@ consFromJSON jc tName opts instTys cons = do

8711006 . stringL

8721007 . constructorTagModifier opts

8731008 . nameBase

874− . constructorName

1009+ . getConName

8751010 ) cons

8761011 )

8771012 `appE` ([|T.unpack|] `appE` varE conKey)

@@ -920,42 +1055,22 @@ parseRecord :: JSONClass

9201055 -> Options

9211056 -> Name

9221057 -> Name

923− -> [Name]

1058+ -> [VarStrictType]

9241059 -> Name

925− -> Bool

9261060 -> ExpQ

927−parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =

928− (if rejectUnknownFields opts

929− then infixApp checkUnknownRecords [|(>>)|]

930− else id) $

1061+parseRecord jc tvMap argTys opts tName conName ts obj =

9311062 foldl' (\a b -> infixApp a [|(<*>)|] b)

9321063 (infixApp (conE conName) [|(<$>)|] x)

9331064 xs

9341065 where

935− tagFieldNameAppender =

936− if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id

937− knownFields = appE [|H.fromList|] $ listE $

938− map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $

939− tagFieldNameAppender $ map nameBase fields

940− checkUnknownRecords =

941− caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)

942− [ match (listP []) (normalB [|return ()|]) []

943− , newName "unknownFields" >>=

944− \unknownFields -> match (varP unknownFields)

945− (normalB $ appE [|fail|] $ infixApp

946− (litE (stringL "Unknown fields: "))

947− [|(++)|]

948− (appE [|show|] (varE unknownFields)))

949− []

950− ]

9511066 x:xs = [ [|lookupField|]

9521067 `appE` dispatchParseJSON jc conName tvMap argTy

9531068 `appE` litE (stringL $ show tName)

9541069 `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)

9551070 `appE` varE obj

956− `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)

1071+ `appE` ( [|T.pack|] `appE` fieldLabelExp opts field

9571072 )

958− | (field, argTy) <- zip fields argTys

1073+ | ((field, _, _), argTy) <- zip ts argTys

9591074 ]

9601075

9611076getValField :: Name -> String -> [MatchQ] -> Q Exp

@@ -974,82 +1089,67 @@ matchCases (Right valName) = caseE (varE valName)

9741089

9751090-- | Generates code to parse the JSON encoding of a single constructor.

9761091parseArgs :: JSONClass -- ^ The FromJSON variant being derived.

977− -> TyVarMap -- ^ Maps the last type variables to their decoding

978− -- function arguments.

1092+ -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.

9791093 -> Name -- ^ Name of the type to which the constructor belongs.

9801094 -> Options -- ^ Encoding options.

981− -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.

1095+ -> Con -- ^ Constructor for which to generate JSON parsing code.

9821096 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or

9831097 -- Right valName

9841098 -> Q Exp

9851099-- Nullary constructors.

986−parseArgs _ _ _ _

987− ConstructorInfo { constructorName = conName

988− , constructorVariant = NormalConstructor

989− , constructorFields = [] }

990− (Left _) =

991− [|pure|] `appE` conE conName

992−parseArgs _ _ tName _

993− ConstructorInfo { constructorName = conName

994− , constructorVariant = NormalConstructor

995− , constructorFields = [] }

996− (Right valName) =

997− caseE (varE valName) $ parseNullaryMatches tName conName

1100+parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do

1101+ ([], _) <- reifyConTys jc pjs conName

1102+ [|pure|] `appE` conE conName

1103+parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do

1104+ ([], _) <- reifyConTys jc pjs conName

1105+ caseE (varE valName) $ parseNullaryMatches tName conName

9981106

9991107-- Unary constructors.

1000−parseArgs jc tvMap _ _

1001− ConstructorInfo { constructorName = conName

1002− , constructorVariant = NormalConstructor

1003− , constructorFields = [argTy] }

1004− contents = do

1005− argTy' <- resolveTypeSynonyms argTy

1006− matchCases contents $ parseUnaryMatches jc tvMap argTy' conName

1108+parseArgs jc pjs _ _ (NormalC conName [_]) contents = do

1109+ ([argTy], tvMap) <- reifyConTys jc pjs conName

1110+ matchCases contents $ parseUnaryMatches jc tvMap argTy conName

10071111

10081112-- Polyadic constructors.

1009−parseArgs jc tvMap tName _

1010− ConstructorInfo { constructorName = conName

1011− , constructorVariant = NormalConstructor

1012− , constructorFields = argTys }

1013− contents = do

1014− argTys' <- mapM resolveTypeSynonyms argTys

1015− let len = genericLength argTys'

1016− matchCases contents $ parseProduct jc tvMap argTys' tName conName len

1113+parseArgs jc pjs tName _ (NormalC conName ts) contents = do

1114+ (argTys, tvMap) <- reifyConTys jc pjs conName

1115+ let len = genericLength ts

1116+ matchCases contents $ parseProduct jc tvMap argTys tName conName len

10171117

10181118-- Records.

1019−parseArgs jc tvMap tName opts

1020− ConstructorInfo { constructorName = conName

1021− , constructorVariant = RecordConstructor fields

1022− , constructorFields = argTys }

1023− (Left (_, obj)) = do

1024− argTys' <- mapM resolveTypeSynonyms argTys

1025− parseRecord jc tvMap argTys' opts tName conName fields obj True

1026−parseArgs jc tvMap tName opts

1027− info@ConstructorInfo { constructorName = conName

1028− , constructorVariant = RecordConstructor fields

1029− , constructorFields = argTys }

1030− (Right valName) =

1031− case (unwrapUnaryRecords opts,argTys) of

1032− (True,[_])-> parseArgs jc tvMap tName opts

1033− (info{constructorVariant = NormalConstructor})

1034− (Right valName)

1035− _ -> do

1036− obj <- newName "recObj"

1037− argTys' <- mapM resolveTypeSynonyms argTys

1038− caseE (varE valName)

1039− [ match (conP 'Object [varP obj]) (normalB $

1040− parseRecord jc tvMap argTys' opts tName conName fields obj False) []

1041− , matchFailed tName conName "Object"

1042− ]

1119+parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do

1120+ (argTys, tvMap) <- reifyConTys jc pjs conName

1121+ parseRecord jc tvMap argTys opts tName conName ts obj

1122+parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of

1123+ (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)

1124+ _ -> do

1125+ obj <- newName "recObj"

1126+ (argTys, tvMap) <- reifyConTys jc pjs conName

1127+ caseE (varE valName)

1128+ [ match (conP 'Object [varP obj]) (normalB $

1129+ parseRecord jc tvMap argTys opts tName conName ts obj) []

1130+ , matchFailed tName conName "Object"

1131+ ]

10431132

10441133-- Infix constructors. Apart from syntax these are the same as

10451134-- polyadic constructors.

1046−parseArgs jc tvMap tName _

1047− ConstructorInfo { constructorName = conName

1048− , constructorVariant = InfixConstructor

1049− , constructorFields = argTys }

1050− contents = do

1051− argTys' <- mapM resolveTypeSynonyms argTys

1052− matchCases contents $ parseProduct jc tvMap argTys' tName conName 2

1135+parseArgs jc pjs tName _ (InfixC _ conName _) contents = do

1136+ (argTys, tvMap) <- reifyConTys jc pjs conName

1137+ matchCases contents $ parseProduct jc tvMap argTys tName conName 2

1138+

1139+-- Existentially quantified constructors. We ignore the quantifiers

1140+-- and proceed with the contained constructor.

1141+parseArgs jc pjs tName opts (ForallC _ _ con) contents =

1142+ parseArgs jc pjs tName opts con contents

1143+

1144+#if MIN_VERSION_template_haskell(2,11,0)

1145+-- GADTs. We ignore the refined return type and proceed as if it were a

1146+-- NormalC or RecC.

1147+parseArgs jc pjs tName opts (GadtC conNames ts _) contents =

1148+ parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents

1149+

1150+parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =

1151+ parseArgs jc pjs tName opts (RecC (head conNames) ts) contents

1152+#endif

10531153

10541154-- | Generates code to parse the JSON encoding of an n-ary

10551155-- constructor.

@@ -1126,11 +1226,6 @@ instance OVERLAPPABLE_ LookupField a where

11261226instance INCOHERENT_ LookupField (Maybe a) where

11271227 lookupField pj _ _ = parseOptionalFieldWith pj

11281228

1129−instance INCOHERENT_ LookupField (Semigroup.Option a) where

1130− lookupField pj tName rec obj key =

1131− fmap Semigroup.Option

1132− (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)

1133−

11341229lookupFieldWith :: (Value -> Parser a) -> String -> String

11351230 -> Object -> T.Text -> Parser a

11361231lookupFieldWith pj tName rec obj key =

@@ -1138,6 +1233,9 @@ lookupFieldWith pj tName rec obj key =

11381233 Nothing -> unknownFieldFail tName rec (T.unpack key)

11391234 Just v -> pj v <?> Key key

11401235

1236+keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair

1237+keyValuePairWith tj name value = (name, tj value)

1238+

11411239unknownFieldFail :: String -> String -> String -> Parser fail

11421240unknownFieldFail tName rec key =

11431241 fail $ printf "When parsing the record %s of type %s the key %s was not present."

@@ -1206,8 +1304,7 @@ deriveJSONBoth dtj dfj opts name =

12061304 liftM2 (++) (dtj opts name) (dfj opts name)

12071305

12081306-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.

1209−deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]

1210− -> [ConstructorInfo] -> Q Exp)]

1307+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]

12111308 -- ^ The class methods and the functions which derive them.

12121309 -> JSONClass

12131310 -- ^ The class for which to generate an instance.

@@ -1217,34 +1314,27 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]

12171314 -- ^ Name of the type for which to generate a class instance

12181315 -- declaration.

12191316 -> Q [Dec]

1220−deriveJSONClass consFuns jc opts name = do

1221− info <- reifyDatatype name

1222− case info of

1223− DatatypeInfo { datatypeContext = ctxt

1224− , datatypeName = parentName

1225−#if MIN_VERSION_th_abstraction(0,3,0)

1226− , datatypeInstTypes = instTys

1227−#else

1228− , datatypeVars = instTys

1229−#endif

1230− , datatypeVariant = variant

1231− , datatypeCons = cons

1232− } -> do

1233− (instanceCxt, instanceType)

1234− <- buildTypeInstance parentName jc ctxt instTys variant

1235− (:[]) <$> instanceD (return instanceCxt)

1236− (return instanceType)

1237− (methodDecs parentName instTys cons)

1317+deriveJSONClass consFuns jc opts name =

1318+ withType name $ \name' ctxt tvbs cons mbTys ->

1319+ (:[]) <$> fromCons name' ctxt tvbs cons mbTys

12381320 where

1239− methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]

1240− methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->

1321+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec

1322+ fromCons name' ctxt tvbs cons mbTys = do

1323+ (instanceCxt, instanceType)

1324+ <- buildTypeInstance name' jc ctxt tvbs mbTys

1325+ instanceD (return instanceCxt)

1326+ (return instanceType)

1327+ (methodDecs name' cons)

1328+

1329+ methodDecs :: Name -> [Con] -> [Q Dec]

1330+ methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->

12411331 funD (jsonFunValName jf (arity jc))

12421332 [ clause []

1243− (normalB $ jfMaker jc parentName opts instTys cons)

1333+ (normalB $ jfMaker jc name' opts cons)

12441334 []

12451335 ]

12461336

1247−mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)

1337+mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)

12481338 -- ^ The function which derives the expression.

12491339 -> JSONClass

12501340 -- ^ Which class's method is being derived.

@@ -1253,24 +1343,15 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q

12531343 -> Name

12541344 -- ^ Name of the encoded type.

12551345 -> Q Exp

1256−mkFunCommon consFun jc opts name = do

1257− info <- reifyDatatype name

1258− case info of

1259− DatatypeInfo { datatypeContext = ctxt

1260− , datatypeName = parentName

1261−#if MIN_VERSION_th_abstraction(0,3,0)

1262− , datatypeInstTypes = instTys

1263−#else

1264− , datatypeVars = instTys

1265−#endif

1266− , datatypeVariant = variant

1267− , datatypeCons = cons

1268− } -> do

1269− -- We force buildTypeInstance here since it performs some checks for whether

1270− -- or not the provided datatype's kind matches the derived method's

1271− -- typeclass, and produces errors if it can't.

1272− !_ <- buildTypeInstance parentName jc ctxt instTys variant

1273− consFun jc parentName opts instTys cons

1346+mkFunCommon consFun jc opts name = withType name fromCons

1347+ where

1348+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp

1349+ fromCons name' ctxt tvbs cons mbTys = do

1350+ -- We force buildTypeInstance here since it performs some checks for whether

1351+ -- or not the provided datatype's kind matches the derived method's

1352+ -- typeclass, and produces errors if it can't.

1353+ !_ <- buildTypeInstance name' jc ctxt tvbs mbTys

1354+ consFun jc name' opts cons

12741355

12751356dispatchFunByType :: JSONClass

12761357 -> JSONFun

@@ -1315,37 +1396,200 @@ dispatchFunByType jc jf conName tvMap list ty = do

13151396 (interleave rhsArgs rhsArgs)

13161397 else varE $ jsonFunValOrListName list jf Arity0

13171398

1318−dispatchToJSON

1319− :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp

1320−dispatchToJSON target jc n tvMap =

1321− dispatchFunByType jc (targetToJSONFun target) n tvMap False

1322−

1323−dispatchParseJSON

1399+dispatchToJSON, dispatchToEncoding, dispatchParseJSON

13241400 :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp

1401+dispatchToJSON jc n tvMap = dispatchFunByType jc ToJSON n tvMap False

1402+dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False

13251403dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False

13261404

13271405--------------------------------------------------------------------------------

13281406-- Utility functions

13291407--------------------------------------------------------------------------------

13301408

1331−-- For the given Types, generate an instance context and head.

1409+-- | Boilerplate for top level splices.

1410+--

1411+-- The given 'Name' must meet one of two criteria:

1412+--

1413+-- 1. It must be the name of a type constructor of a plain data type or newtype.

1414+-- 2. It must be the name of a data family instance or newtype instance constructor.

1415+

1416+-- Any other value will result in an exception.

1417+withType :: Name

1418+ -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)

1419+ -- ^ Function that generates the actual code. Will be applied

1420+ -- to the datatype/data family 'Name', datatype context, type

1421+ -- variable binders and constructors extracted from the given

1422+ -- 'Name'. If the 'Name' is from a data family instance

1423+ -- constructor, it will also have its instantiated types;

1424+ -- otherwise, it will be 'Nothing'.

1425+ -> Q a

1426+ -- ^ Resulting value in the 'Q'uasi monad.

1427+withType name f = do

1428+ info <- reify name

1429+ case info of

1430+ TyConI dec ->

1431+ case dec of

1432+#if MIN_VERSION_template_haskell(2,11,0)

1433+ DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing

1434+ NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing

1435+#else

1436+ DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing

1437+ NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing

1438+#endif

1439+ other -> fail $ ns ++ "Unsupported type: " ++ show other

1440+#if MIN_VERSION_template_haskell(2,11,0)

1441+ DataConI _ _ parentName -> do

1442+#else

1443+ DataConI _ _ parentName _ -> do

1444+#endif

1445+ parentInfo <- reify parentName

1446+ case parentInfo of

1447+#if MIN_VERSION_template_haskell(2,11,0)

1448+ FamilyI (DataFamilyD _ tvbs _) decs ->

1449+#else

1450+ FamilyI (FamilyD DataFam _ tvbs _) decs ->

1451+#endif

1452+ let instDec = flip find decs $ \dec -> case dec of

1453+#if MIN_VERSION_template_haskell(2,11,0)

1454+ DataInstD _ _ _ _ cons _ -> any ((name ==) . getConName) cons

1455+ NewtypeInstD _ _ _ _ con _ -> name == getConName con

1456+#else

1457+ DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons

1458+ NewtypeInstD _ _ _ con _ -> name == getConName con

1459+#endif

1460+ _ -> error $ ns ++ "Must be a data or newtype instance."

1461+ in case instDec of

1462+#if MIN_VERSION_template_haskell(2,11,0)

1463+ Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys

1464+ Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys

1465+#else

1466+ Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys

1467+ Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys

1468+#endif

1469+ _ -> fail $ ns ++

1470+ "Could not find data or newtype instance constructor."

1471+ _ -> fail $ ns ++ "Data constructor " ++ show name ++

1472+ " is not from a data family instance constructor."

1473+#if MIN_VERSION_template_haskell(2,11,0)

1474+ FamilyI DataFamilyD{} _ ->

1475+#else

1476+ FamilyI (FamilyD DataFam _ _ _) _ ->

1477+#endif

1478+ fail $ ns ++

1479+ "Cannot use a data family name. Use a data family instance constructor instead."

1480+ _ -> fail $ ns ++ "I need the name of a plain data type constructor, "

1481+ ++ "or a data family instance constructor."

1482+ where

1483+ ns :: String

1484+ ns = "Data.Aeson.TH.withType: "

1485+

1486+-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.

13321487buildTypeInstance :: Name

13331488 -- ^ The type constructor or data family name

13341489 -> JSONClass

13351490 -- ^ The typeclass to derive

13361491 -> Cxt

13371492 -- ^ The datatype context

1338− -> [Type]

1339− -- ^ The types to instantiate the instance with

1340− -> DatatypeVariant

1341− -- ^ Are we dealing with a data family instance or not

1493+ -> [TyVarBndr]

1494+ -- ^ The type variables from the data type/data family declaration

1495+ -> Maybe [Type]

1496+ -- ^ 'Just' the types used to instantiate a data family instance,

1497+ -- or 'Nothing' if it's a plain data type

13421498 -> Q (Cxt, Type)

1343−buildTypeInstance tyConName jc dataCxt varTysOrig variant = do

1499+ -- ^ The resulting 'Cxt' and 'Type' to use in a class instance

1500+-- Plain data type/newtype case

1501+buildTypeInstance tyConName jc dataCxt tvbs Nothing =

1502+ let varTys :: [Type]

1503+ varTys = map tvbToType tvbs

1504+ in buildTypeInstanceFromTys tyConName jc dataCxt varTys False

1505+-- Data family instance case

1506+--

1507+-- The CPP is present to work around a couple of annoying old GHC bugs.

1508+-- See Note [Polykinded data families in Template Haskell]

1509+buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do

1510+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)

1511+ let instTys :: [Type]

1512+ instTys = zipWith stealKindForType tvbs instTysAndKinds

1513+#else

1514+ let kindVarNames :: [Name]

1515+ kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs

1516+

1517+ numKindVars :: Int

1518+ numKindVars = length kindVarNames

1519+

1520+ givenKinds, givenKinds' :: [Kind]

1521+ givenTys :: [Type]

1522+ (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds

1523+ givenKinds' = map sanitizeStars givenKinds

1524+

1525+ -- A GHC 7.6-specific bug requires us to replace all occurrences of

1526+ -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.

1527+ -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.

1528+ sanitizeStars :: Kind -> Kind

1529+ sanitizeStars = go

1530+ where

1531+ go :: Kind -> Kind

1532+ go (AppT t1 t2) = AppT (go t1) (go t2)

1533+ go (SigT t k) = SigT (go t) (go k)

1534+ go (ConT n) | n == starKindName = StarT

1535+ go t = t

1536+

1537+ -- It's quite awkward to import * from GHC.Prim, so we'll just

1538+ -- hack our way around it.

1539+ starKindName :: Name

1540+ starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"

1541+

1542+ -- If we run this code with GHC 7.8, we might have to generate extra type

1543+ -- variables to compensate for any type variables that Template Haskell

1544+ -- eta-reduced away.

1545+ -- See Note [Polykinded data families in Template Haskell]

1546+ xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)

1547+

1548+ let xTys :: [Type]

1549+ xTys = map VarT xTypeNames

1550+ -- ^ Because these type variables were eta-reduced away, we can only

1551+ -- determine their kind by using stealKindForType. Therefore, we mark

1552+ -- them as VarT to ensure they will be given an explicit kind annotation

1553+ -- (and so the kind inference machinery has the right information).

1554+

1555+ substNamesWithKinds :: [(Name, Kind)] -> Type -> Type

1556+ substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks

1557+

1558+ -- The types from the data family instance might not have explicit kind

1559+ -- annotations, which the kind machinery needs to work correctly. To

1560+ -- compensate, we use stealKindForType to explicitly annotate any

1561+ -- types without kind annotations.

1562+ instTys :: [Type]

1563+ instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))

1564+ -- Note that due to a GHC 7.8-specific bug

1565+ -- (see Note [Polykinded data families in Template Haskell]),

1566+ -- there may be more kind variable names than there are kinds

1567+ -- to substitute. But this is OK! If a kind is eta-reduced, it

1568+ -- means that is was not instantiated to something more specific,

1569+ -- so we need not substitute it. Using stealKindForType will

1570+ -- grab the correct kind.

1571+ $ zipWith stealKindForType tvbs (givenTys ++ xTys)

1572+#endif

1573+ buildTypeInstanceFromTys dataFamName jc dataCxt instTys True

1574+

1575+-- For the given Types, generate an instance context and head.

1576+buildTypeInstanceFromTys :: Name

1577+ -- ^ The type constructor or data family name

1578+ -> JSONClass

1579+ -- ^ The typeclass to derive

1580+ -> Cxt

1581+ -- ^ The datatype context

1582+ -> [Type]

1583+ -- ^ The types to instantiate the instance with

1584+ -> Bool

1585+ -- ^ True if it's a data family, False otherwise

1586+ -> Q (Cxt, Type)

1587+buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do

13441588 -- Make sure to expand through type/kind synonyms! Otherwise, the

13451589 -- eta-reduction check might get tripped up over type variables in a

13461590 -- synonym that are actually dropped.

13471591 -- (See GHC Trac #11416 for a scenario where this actually happened.)

1348− varTysExp <- mapM resolveTypeSynonyms varTysOrig

1592+ varTysExp <- mapM expandSyn varTysOrig

13491593

13501594 let remainingLength :: Int

13511595 remainingLength = length varTysOrig - arityInt jc

@@ -1375,7 +1619,7 @@ buildTypeInstance tyConName jc dataCxt varTysOrig variant = do

13751619 -- All of the type variables mentioned in the dropped types

13761620 -- (post-synonym expansion)

13771621 droppedTyVarNames :: [Name]

1378− droppedTyVarNames = freeVariables droppedTysExpSubst

1622+ droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst

13791623

13801624 -- If any of the dropped types were polykinded, ensure that they are of kind *

13811625 -- after substituting * for the dropped kind variables. If not, throw an error.

@@ -1413,16 +1657,9 @@ buildTypeInstance tyConName jc dataCxt varTysOrig variant = do

14131657 -- instance C (Fam [Char])

14141658 remainingTysOrigSubst :: [Type]

14151659 remainingTysOrigSubst =

1416− map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))

1660+ map (substNamesWithKindStar (union droppedKindVarNames kvNames'))

14171661 $ take remainingLength varTysOrig

14181662

1419− isDataFamily :: Bool

1420− isDataFamily = case variant of

1421− Datatype -> False

1422− Newtype -> False

1423− DataInstance -> True

1424− NewtypeInstance -> True

1425−

14261663 remainingTysOrigSubst' :: [Type]

14271664 -- See Note [Kind signatures in derived instances] for an explanation

14281665 -- of the isDataFamily check.

@@ -1476,6 +1713,55 @@ deriveConstraint jc t

14761713 jcConstraint = jsonClassName . JSONClass (direction jc)

14771714

14781715{-

1716+Note [Polykinded data families in Template Haskell]

1717+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

1718+

1719+In order to come up with the correct instance context and head for an instance, e.g.,

1720+

1721+ instance C a => C (Data a) where ...

1722+

1723+We need to know the exact types and kinds used to instantiate the instance. For

1724+plain old datatypes, this is simple: every type must be a type variable, and

1725+Template Haskell reliably tells us the type variables and their kinds.

1726+

1727+Doing the same for data families proves to be much harder for three reasons:

1728+

1729+1. On any version of Template Haskell, it may not tell you what an instantiated

1730+ type's kind is. For instance, in the following data family instance:

1731+

1732+ data family Fam (f :: * -> *) (a :: *)

1733+ data instance Fam f a

1734+

1735+ Then if we use TH's reify function, it would tell us the TyVarBndrs of the

1736+ data family declaration are:

1737+

1738+ [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]

1739+

1740+ and the instantiated types of the data family instance are:

1741+

1742+ [VarT f1,VarT a1]

1743+

1744+ We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we

1745+ have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the

1746+ kind is in case an instantiated type isn't a SigT, so we use the stealKindForType

1747+ function to ensure all of the instantiated types are SigTs before passing them

1748+ to buildTypeInstanceFromTys.

1749+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of

1750+ the specified kinds of a data family instance efore any of the instantiated

1751+ types. Fortunately, this is easy to deal with: you simply count the number of

1752+ distinct kind variables in the data family declaration, take that many elements

1753+ from the front of the Types list of the data family instance, substitute the

1754+ kind variables with their respective instantiated kinds (which you took earlier),

1755+ and proceed as normal.

1756+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template

1757+ Haskell might not even list all of the Types of a data family instance, since

1758+ they are eta-reduced away! And yes, kinds can be eta-reduced too.

1759+

1760+ The simplest workaround is to count how many instantiated types are missing from

1761+ the list and generate extra type variables to use in their place. Luckily, we

1762+ needn't worry much if its kind was eta-reduced away, since using stealKindForType

1763+ will get it back.

1764+

14791765Note [Kind signatures in derived instances]

14801766~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

14811767

@@ -1553,14 +1839,50 @@ things we can do to make instance contexts that work for 80% of use cases:

15531839 and perform kind substitution as in the other cases.

15541840-}

15551841

1556−checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name

1557− -> Q a -> Q a

1558−checkExistentialContext jc tvMap ctxt conName q =

1559− if (any (`predMentionsName` M.keys tvMap) ctxt

1560− || M.size tvMap < arityInt jc)

1561− && not (allowExQuant jc)

1562− then existentialContextError conName

1563− else q

1842+-- Determines the types of a constructor's arguments as well as the last type

1843+-- parameters (mapped to their encoding/decoding functions), expanding through

1844+-- any type synonyms.

1845+--

1846+-- The type parameters are determined on a constructor-by-constructor basis since

1847+-- they may be refined to be particular types in a GADT.

1848+reifyConTys :: JSONClass

1849+ -> [(Name, Name)]

1850+ -> Name

1851+ -> Q ([Type], TyVarMap)

1852+reifyConTys jc tpjs conName = do

1853+ info <- reify conName

1854+ (ctxt, uncTy) <- case info of

1855+ DataConI _ ty _

1856+#if !(MIN_VERSION_template_haskell(2,11,0))

1857+ _

1858+#endif

1859+ -> fmap uncurryTy (expandSyn ty)

1860+ _ -> error "Must be a data constructor"

1861+ let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy

1862+ unapResTy = unapplyTy resTy

1863+ -- If one of the last type variables is refined to a particular type

1864+ -- (i.e., not truly polymorphic), we mark it with Nothing and filter

1865+ -- it out later, since we only apply encoding/decoding functions to

1866+ -- arguments of a type that it (1) one of the last type variables,

1867+ -- and (2) of a truly polymorphic type.

1868+ jArity = arityInt jc

1869+ mbTvNames = map varTToNameMaybe $

1870+ NE.drop (NE.length unapResTy - jArity) unapResTy

1871+ -- We use M.fromList to ensure that if there are any duplicate type

1872+ -- variables (as can happen in a GADT), the rightmost type variable gets

1873+ -- associated with the show function.

1874+ --

1875+ -- See Note [Matching functions with GADT type variables]

1876+ tvMap = M.fromList

1877+ . catMaybes -- Drop refined types

1878+ $ zipWith (\mbTvName tpj ->

1879+ fmap (\tvName -> (tvName, tpj)) mbTvName)

1880+ mbTvNames tpjs

1881+ if (any (`predMentionsName` M.keys tvMap) ctxt

1882+ || M.size tvMap < jArity)

1883+ && not (allowExQuant jc)

1884+ then existentialContextError conName

1885+ else return (argTys, tvMap)

15641886

15651887{-

15661888Note [Matching functions with GADT type variables]

@@ -1600,22 +1922,69 @@ Both.

16001922-- are the function arguments of types (b -> Value) and ([b] -> Value).

16011923type TyVarMap = Map Name (Name, Name)

16021924

1925+-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.

1926+stealKindForType :: TyVarBndr -> Type -> Type

1927+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)

1928+stealKindForType _ t = t

1929+

1930+-- | Extracts the kind from a type variable binder.

1931+tvbKind :: TyVarBndr -> Kind

1932+#if MIN_VERSION_template_haskell(2,8,0)

1933+tvbKind (PlainTV _ ) = StarT

1934+#else

1935+tvbKind (PlainTV _ ) = StarK

1936+#endif

1937+tvbKind (KindedTV _ k) = k

1938+

1939+tvbToType :: TyVarBndr -> Type

1940+tvbToType (PlainTV n) = VarT n

1941+tvbToType (KindedTV n k) = SigT (VarT n) k

1942+

16031943-- | Returns True if a Type has kind *.

16041944hasKindStar :: Type -> Bool

16051945hasKindStar VarT{} = True

1946+#if MIN_VERSION_template_haskell(2,8,0)

16061947hasKindStar (SigT _ StarT) = True

1948+#else

1949+hasKindStar (SigT _ StarK) = True

1950+#endif

16071951hasKindStar _ = False

16081952

16091953-- Returns True is a kind is equal to *, or if it is a kind variable.

16101954isStarOrVar :: Kind -> Bool

1955+#if MIN_VERSION_template_haskell(2,8,0)

16111956isStarOrVar StarT = True

16121957isStarOrVar VarT{} = True

1958+#else

1959+isStarOrVar StarK = True

1960+#endif

16131961isStarOrVar _ = False

16141962

16151963-- Generate a list of fresh names with a common prefix, and numbered suffixes.

16161964newNameList :: String -> Int -> Q [Name]

16171965newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]

16181966

1967+-- Gets all of the type/kind variable names mentioned somewhere in a Type.

1968+tyVarNamesOfType :: Type -> [Name]

1969+tyVarNamesOfType = go

1970+ where

1971+ go :: Type -> [Name]

1972+ go (AppT t1 t2) = go t1 ++ go t2

1973+ go (SigT t _k) = go t

1974+#if MIN_VERSION_template_haskell(2,8,0)

1975+ ++ go _k

1976+#endif

1977+ go (VarT n) = [n]

1978+ go _ = []

1979+

1980+-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.

1981+tyVarNamesOfKind :: Kind -> [Name]

1982+#if MIN_VERSION_template_haskell(2,8,0)

1983+tyVarNamesOfKind = tyVarNamesOfType

1984+#else

1985+tyVarNamesOfKind _ = [] -- There are no kind variables

1986+#endif

1987+

16191988-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form

16201989-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or

16211990-- kind variables.

@@ -1623,7 +1992,7 @@ hasKindVarChain :: Int -> Type -> Maybe [Name]

16231992hasKindVarChain kindArrows t =

16241993 let uk = uncurryKind (tyKind t)

16251994 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk

1626− then Just (concatMap freeVariables uk)

1995+ then Just (concatMap tyVarNamesOfKind uk)

16271996 else Nothing

16281997

16291998-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.

@@ -1643,6 +2012,17 @@ varTToNameMaybe _ = Nothing

16432012varTToName :: Type -> Name

16442013varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe

16452014

2015+-- | Extracts the name from a constructor.

2016+getConName :: Con -> Name

2017+getConName (NormalC name _) = name

2018+getConName (RecC name _) = name

2019+getConName (InfixC _ name _) = name

2020+getConName (ForallC _ _ con) = getConName con

2021+#if MIN_VERSION_template_haskell(2,11,0)

2022+getConName (GadtC names _ _) = head names

2023+getConName (RecGadtC names _ _) = head names

2024+#endif

2025+

16462026interleave :: [a] -> [a] -> [a]

16472027interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s

16482028interleave _ _ = []

@@ -1667,7 +2047,9 @@ isTyFamily (ConT n) = do

16672047#else

16682048 FamilyI (FamilyD TypeFam _ _ _) _ -> True

16692049#endif

2050+#if MIN_VERSION_template_haskell(2,9,0)

16702051 FamilyI ClosedTypeFamilyD{} _ -> True

2052+#endif

16712053 _ -> False

16722054isTyFamily _ = return False

16732055

@@ -1695,7 +2077,9 @@ mentionsName = go

16952077 go :: Type -> [Name] -> Bool

16962078 go (AppT t1 t2) names = go t1 names || go t2 names

16972079 go (SigT t _k) names = go t names

2080+#if MIN_VERSION_template_haskell(2,8,0)

16982081 || go _k names

2082+#endif

16992083 go (VarT n) names = n `elem` names

17002084 go _ _ = False

17012085

@@ -1751,28 +2135,37 @@ uncurryTy t = ([], t :| [])

17512135

17522136-- | Like uncurryType, except on a kind level.

17532137uncurryKind :: Kind -> NonEmpty Kind

2138+#if MIN_VERSION_template_haskell(2,8,0)

17542139uncurryKind = snd . uncurryTy

2140+#else

2141+uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2

2142+uncurryKind k = k :| []

2143+#endif

17552144

17562145createKindChain :: Int -> Kind

17572146createKindChain = go starK

17582147 where

17592148 go :: Kind -> Int -> Kind

1760− go k 0 = k

2149+ go k !0 = k

2150+#if MIN_VERSION_template_haskell(2,8,0)

17612151 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)

2152+#else

2153+ go k !n = go (ArrowK StarK k) (n - 1)

2154+#endif

17622155

17632156-- | Makes a string literal expression from a constructor's name.

1764−conNameExp :: Options -> ConstructorInfo -> Q Exp

2157+conNameExp :: Options -> Con -> Q Exp

17652158conNameExp opts = litE

17662159 . stringL

17672160 . constructorTagModifier opts

17682161 . nameBase

1769− . constructorName

2162+ . getConName

17702163

1771−-- | Extracts a record field label.

1772−fieldLabel :: Options -- ^ Encoding options

1773− -> Name

1774− -> String

1775−fieldLabel opts = fieldLabelModifier opts . nameBase

2164+-- | Creates a string literal expression from a record field label.

2165+fieldLabelExp :: Options -- ^ Encoding options

2166+ -> Name

2167+ -> Q Exp

2168+fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase

17762169

17772170-- | The name of the outermost 'Value' constructor.

17782171valueConName :: Value -> String

@@ -1811,14 +2204,76 @@ canEtaReduce remaining dropped =

18112204-- Expanding type synonyms

18122205-------------------------------------------------------------------------------

18132206

1814−applySubstitutionKind :: Map Name Kind -> Type -> Type

1815−applySubstitutionKind = applySubstitution

2207+-- | Expands all type synonyms in a type. Written by Dan Rosén in the

2208+-- @genifunctors@ package (licensed under BSD3).

2209+expandSyn :: Type -> Q Type

2210+expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t

2211+expandSyn t@AppT{} = expandSynApp t []

2212+expandSyn t@ConT{} = expandSynApp t []

2213+expandSyn (SigT t k) = do t' <- expandSyn t

2214+ k' <- expandSynKind k

2215+ return (SigT t' k')

2216+expandSyn t = return t

2217+

2218+expandSynKind :: Kind -> Q Kind

2219+#if MIN_VERSION_template_haskell(2,8,0)

2220+expandSynKind = expandSyn

2221+#else

2222+expandSynKind = return -- There are no kind synonyms to deal with

2223+#endif

2224+

2225+expandSynApp :: Type -> [Type] -> Q Type

2226+expandSynApp (AppT t1 t2) ts = do

2227+ t2' <- expandSyn t2

2228+ expandSynApp t1 (t2':ts)

2229+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts

2230+expandSynApp t@(ConT n) ts = do

2231+ info <- reify n

2232+ case info of

2233+ TyConI (TySynD _ tvs rhs) ->

2234+ let (ts', ts'') = splitAt (length tvs) ts

2235+ subs = mkSubst tvs ts'

2236+ rhs' = substType subs rhs

2237+ in expandSynApp rhs' ts''

2238+ _ -> return $ foldl' AppT t ts

2239+expandSynApp t ts = do

2240+ t' <- expandSyn t

2241+ return $ foldl' AppT t' ts

2242+

2243+type TypeSubst = Map Name Type

2244+type KindSubst = Map Name Kind

2245+

2246+mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst

2247+mkSubst vs ts =

2248+ let vs' = map un vs

2249+ un (PlainTV v) = v

2250+ un (KindedTV v _) = v

2251+ in M.fromList $ zip vs' ts

2252+

2253+substType :: TypeSubst -> Type -> Type

2254+substType subs (ForallT v c t) = ForallT v c $ substType subs t

2255+substType subs t@(VarT n) = M.findWithDefault t n subs

2256+substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)

2257+substType subs (SigT t k) = SigT (substType subs t)

2258+#if MIN_VERSION_template_haskell(2,8,0)

2259+ (substType subs k)

2260+#else

2261+ k

2262+#endif

2263+substType _ t = t

2264+

2265+substKind :: KindSubst -> Type -> Type

2266+#if MIN_VERSION_template_haskell(2,8,0)

2267+substKind = substType

2268+#else

2269+substKind _ t = t -- There are no kind variables!

2270+#endif

18162271

18172272substNameWithKind :: Name -> Kind -> Type -> Type

1818−substNameWithKind n k = applySubstitutionKind (M.singleton n k)

2273+substNameWithKind n k = substKind (M.singleton n k)

18192274

18202275substNamesWithKindStar :: [Name] -> Type -> Type

1821−substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns

2276+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns

18222277

18232278-------------------------------------------------------------------------------

18242279-- Error messages

@@ -1901,13 +2356,6 @@ data Direction = To | From

19012356-- | A representation of which typeclass method is being spliced in.

19022357data JSONFun = ToJSON | ToEncoding | ParseJSON

19032358

1904−-- | A refinement of JSONFun to [ToJSON, ToEncoding].

1905−data ToJSONFun = Value | Encoding

1906−

1907−targetToJSONFun :: ToJSONFun -> JSONFun

1908−targetToJSONFun Value = ToJSON

1909−targetToJSONFun Encoding = ToEncoding

1910−

19112359-- | A representation of which typeclass is being derived.

19122360data JSONClass = JSONClass { direction :: Direction, arity :: Arity }

19132361

@@ -1974,10 +2422,13 @@ data StarKindStatus = NotKindStar

19742422

19752423-- | Does a Type have kind * or k (for some kind variable k)?

19762424canRealizeKindStar :: Type -> StarKindStatus

1977−canRealizeKindStar t = case t of

1978− _ | hasKindStar t -> KindStar

1979− SigT _ (VarT k) -> IsKindVar k

1980− _ -> NotKindStar

2425+canRealizeKindStar t

2426+ | hasKindStar t = KindStar

2427+ | otherwise = case t of

2428+#if MIN_VERSION_template_haskell(2,8,0)

2429+ SigT _ (VarT k) -> IsKindVar k

2430+#endif

2431+ _ -> NotKindStar

19812432

19822433-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.

19832434-- Otherwise, returns 'Nothing'.

Data/Aeson/Text.hs+4−5

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

32{-# LANGUAGE OverloadedStrings #-}

43-- |

54-- Module: Data.Aeson.Text

@@ -15,18 +14,18 @@

1514--

1615-- You can use the conversions to 'Builder's when embedding JSON messages as

1716-- parts of a protocol.

18−

1917module Data.Aeson.Text

2018 (

2119 encodeToLazyText

2220 , encodeToTextBuilder

2321 ) where

2422

23+import Prelude ()

2524import Prelude.Compat

2625

2726import Data.Aeson.Types (Value(..), ToJSON(..))

2827import Data.Aeson.Encoding (encodingToLazyByteString)

29−import Data.Semigroup ((<>))

28+import Data.Monoid ((<>))

3029import Data.Scientific (FPFormat(..), Scientific, base10Exponent)

3130import Data.Text.Lazy.Builder

3231import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)

@@ -47,8 +46,8 @@ encodeToLazyText = LT.decodeUtf8 . encodingToLazyByteString . toEncoding

4746-- embedded efficiently in a text-based protocol.

4847--

4948-- If you are going to immediately encode straight to a

50−-- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString)

51−-- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead.

49+-- 'L.ByteString', it is more efficient to use 'encodeToBuilder'

50+-- instead.

5251--

5352-- /Note:/ Uses 'toJSON'

5453encodeToTextBuilder :: ToJSON a => a -> Builder

Data/Aeson/Types.hs+5−49

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21-- |

32-- Module: Data.Aeson.Types

@@ -26,7 +25,6 @@ module Data.Aeson.Types

2625 -- * Convenience types and functions

2726 , DotNetTime(..)

2827 , typeMismatch

29− , unexpected

3028 -- * Type conversion

3129 , Parser

3230 , Result(..)

@@ -38,9 +36,6 @@ module Data.Aeson.Types

3836 , ToJSON(..)

3937 , KeyValue(..)

4038 , modifyFailure

41− , prependFailure

42− , parserThrowError

43− , parserCatchError

4439

4540 -- ** Keys for maps

4641 , ToJSONKey(..)

@@ -53,12 +48,6 @@ module Data.Aeson.Types

5348 , coerceFromJSONKeyFunction

5449 , mapFromJSONKeyFunction

5550

56− -- *** Generic keys

57− , GToJSONKey()

58− , genericToJSONKey

59− , GFromJSONKey()

60− , genericFromJSONKey

61−

6251 -- ** Liftings to unary and binary type constructors

6352 , FromJSON1(..)

6453 , parseJSON1

@@ -74,8 +63,8 @@ module Data.Aeson.Types

7463 -- ** Generic JSON classes

7564 , GFromJSON(..)

7665 , FromArgs(..)

77− , GToJSON

78− , GToEncoding

66+ , GToJSON(..)

67+ , GToEncoding(..)

7968 , ToArgs(..)

8069 , Zero

8170 , One

@@ -90,9 +79,9 @@ module Data.Aeson.Types

9079 , withObject

9180 , withText

9281 , withArray

82+ , withNumber

9383 , withScientific

9484 , withBool

95− , withEmbeddedJSON

9685

9786 , pairs

9887 , foldable

@@ -101,51 +90,21 @@ module Data.Aeson.Types

10190 , (.:!)

10291 , (.!=)

10392 , object

104− , parseField

105− , parseFieldMaybe

106− , parseFieldMaybe'

107− , explicitParseField

108− , explicitParseFieldMaybe

109− , explicitParseFieldMaybe'

11093

11194 , listEncoding

11295 , listValue

11396 , listParser

11497

11598 -- * Generic and TH encoding configuration

116− , Options

117−

118− -- ** Options fields

119− -- $optionsFields

120− , fieldLabelModifier

121− , constructorTagModifier

122− , allNullaryToStringTag

123− , omitNothingFields

124− , sumEncoding

125− , unwrapUnaryRecords

126− , tagSingleConstructors

127− , rejectUnknownFields

128−

129− -- ** Options utilities

99+ , Options(..)

130100 , SumEncoding(..)

131101 , camelTo

132102 , camelTo2

133103 , defaultOptions

134104 , defaultTaggedObject

135−

136− -- ** Options for object keys

137− , JSONKeyOptions

138− , keyModifier

139− , defaultJSONKeyOptions

140−

141− -- * Parsing context

142− , (<?>)

143− , JSONPath

144− , JSONPathElement(..)

145− , formatPath

146− , formatRelativePath

147105 ) where

148106

107+import Prelude ()

149108import Prelude.Compat

150109

151110import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs)

@@ -157,6 +116,3 @@ import Data.Foldable (toList)

157116foldable :: (Foldable t, ToJSON a) => t a -> Encoding

158117foldable = toEncoding . toList

159118{-# INLINE foldable #-}

160−

161−-- $optionsFields

162−-- The functions here are in fact record fields of the 'Options' type.

Data/Aeson/Types/Class.hs+7−26

@@ -1,11 +1,10 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

32{-# LANGUAGE FlexibleContexts #-}

43{-# LANGUAGE FlexibleInstances #-}

54{-# LANGUAGE GADTs #-}

65{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE NoImplicitPrelude #-}

86{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeSynonymInstances #-}

109-- |

1110-- Module: Data.Aeson.Types.Class

@@ -37,8 +36,8 @@ module Data.Aeson.Types.Class

3736 -- * Generic JSON classes

3837 , GFromJSON(..)

3938 , FromArgs(..)

40− , GToJSON

41− , GToEncoding

39+ , GToJSON(..)

40+ , GToEncoding(..)

4241 , ToArgs(..)

4342 , Zero

4443 , One

@@ -58,11 +57,6 @@ module Data.Aeson.Types.Class

5857 , fromJSONKeyCoerce

5958 , coerceFromJSONKeyFunction

6059 , mapFromJSONKeyFunction

61− -- ** Generic keys

62− , GToJSONKey()

63− , genericToJSONKey

64− , GFromJSONKey()

65− , genericFromJSONKey

6660 -- * Object key-value pairs

6761 , KeyValue(..)

6862

@@ -75,35 +69,22 @@ module Data.Aeson.Types.Class

7569 , withObject

7670 , withText

7771 , withArray

72+ , withNumber

7873 , withScientific

7974 , withBool

80− , withEmbeddedJSON

8175

8276 -- * Functions

8377 , fromJSON

8478 , ifromJSON

85− , typeMismatch

86− , unexpected

87− , parseField

88− , parseFieldMaybe

89− , parseFieldMaybe'

90− , explicitParseField

91− , explicitParseFieldMaybe

92− , explicitParseFieldMaybe'

93− -- ** Operators

9479 , (.:)

9580 , (.:?)

9681 , (.:!)

9782 , (.!=)

83+ , typeMismatch

9884 ) where

9985

86+import Prelude ()

10087

10188import Data.Aeson.Types.FromJSON

10289import Data.Aeson.Types.Generic (One, Zero)

103−import Data.Aeson.Types.ToJSON hiding (GToJSON)

104−import qualified Data.Aeson.Types.ToJSON as ToJSON

105−import Data.Aeson.Types.Internal (Value)

106−import Data.Aeson.Encoding (Encoding)

107−

108−type GToJSON = ToJSON.GToJSON Value

109−type GToEncoding = ToJSON.GToJSON Encoding

90+import Data.Aeson.Types.ToJSON

Data/Aeson/Types/FromJSON.hs+447−950

@@ -5,16 +5,19 @@

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE GADTs #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE NoImplicitPrelude #-}

8+{-# LANGUAGE NamedFieldPuns #-}

99{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

1110{-# LANGUAGE RecordWildCards #-}

1211{-# LANGUAGE ScopedTypeVariables #-}

1312{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeSynonymInstances #-}

1514{-# LANGUAGE UndecidableInstances #-}

1615{-# LANGUAGE ViewPatterns #-}

1716

17+#if __GLASGOW_HASKELL__ >= 706

18+{-# LANGUAGE PolyKinds #-}

19+#endif

20+

1821#include "incoherent-compat.h"

1922#include "overlapping-compat.h"

2023

@@ -42,9 +45,6 @@ module Data.Aeson.Types.FromJSON

4245 , coerceFromJSONKeyFunction

4346 , mapFromJSONKeyFunction

4447

45− , GFromJSONKey()

46− , genericFromJSONKey

47−

4848 -- * List functions

4949 , listParser

5050

@@ -52,42 +52,34 @@ module Data.Aeson.Types.FromJSON

5252 , withObject

5353 , withText

5454 , withArray

55+ , withNumber

5556 , withScientific

5657 , withBool

57− , withEmbeddedJSON

5858

5959 -- * Functions

6060 , fromJSON

6161 , ifromJSON

62− , typeMismatch

63− , unexpected

64− , parseField

65− , parseFieldMaybe

66− , parseFieldMaybe'

67− , explicitParseField

68− , explicitParseFieldMaybe

69− , explicitParseFieldMaybe'

70− , parseIndexedJSON

71− -- ** Operators

7262 , (.:)

7363 , (.:?)

7464 , (.:!)

7565 , (.!=)

66+ , typeMismatch

7667

7768 -- * Internal

7869 , parseOptionalFieldWith

7970 ) where

8071

72+import Prelude ()

8173import Prelude.Compat

8274

83−import Control.Applicative ((<|>), Const(..), liftA2)

84−import Control.Monad (zipWithM)

75+import Control.Applicative ((<|>), Const(..))

76+import Control.Monad ((<=<), zipWithM)

8577import Data.Aeson.Internal.Functions (mapKey)

86−import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)

8778import Data.Aeson.Types.Generic

8879import Data.Aeson.Types.Internal

80+import Data.Attoparsec.Number (Number(..))

8981import Data.Bits (unsafeShiftR)

90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)

82+import Data.Fixed (Fixed, HasResolution)

9183import Data.Functor.Compose (Compose(..))

9284import Data.Functor.Identity (Identity(..))

9385import Data.Functor.Product (Product(..))

@@ -96,31 +88,26 @@ import Data.Hashable (Hashable(..))

9688import Data.Int (Int16, Int32, Int64, Int8)

9789import Data.List.NonEmpty (NonEmpty(..))

9890import Data.Maybe (fromMaybe)

99−import Data.Semigroup ((<>))

91+import Data.Monoid ((<>))

10092import Data.Proxy (Proxy(..))

10193import Data.Ratio ((%), Ratio)

102−import Data.Scientific (Scientific, base10Exponent)

94+import Data.Scientific (Scientific)

10395import Data.Tagged (Tagged(..))

10496import Data.Text (Text, pack, unpack)

105−import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

106−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

107−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

108−import Data.Time.Clock.System.Compat (SystemTime (..))

109−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)

97+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

98+import Data.Time.Format (parseTime)

99+import Data.Time.Locale.Compat (defaultTimeLocale)

110100import Data.Traversable as Tr (sequence)

111101import Data.Vector (Vector)

112102import Data.Version (Version, parseVersion)

113−import Data.Void (Void)

114103import Data.Word (Word16, Word32, Word64, Word8)

115104import Foreign.Storable (Storable)

116−import Foreign.C.Types (CTime (..))

117105import GHC.Generics

118106import Numeric.Natural (Natural)

119107import Text.ParserCombinators.ReadP (readP_to_S)

120108import Unsafe.Coerce (unsafeCoerce)

121109import qualified Data.Aeson.Parser.Time as Time

122110import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

123−import qualified Data.ByteString.Lazy as L

124111import qualified Data.DList as DList

125112import qualified Data.HashMap.Strict as H

126113import qualified Data.HashSet as HashSet

@@ -143,20 +130,18 @@ import qualified Data.Vector.Primitive as VP

143130import qualified Data.Vector.Storable as VS

144131import qualified Data.Vector.Unboxed as VU

145132

146−import qualified GHC.Exts as Exts

147−import qualified Data.Primitive.Array as PM

148−import qualified Data.Primitive.SmallArray as PM

149−import qualified Data.Primitive.Types as PM

150−

151−#if MIN_VERSION_primitive(0,6,4)

152−#if !MIN_VERSION_primitive(0,7,0)

153−import qualified Data.Primitive.UnliftedArray as PM

154−#endif

155−import qualified Data.Primitive.PrimArray as PM

133+#ifndef HAS_COERCIBLE

134+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)

156135#endif

157136

158−

137+#if HAS_COERCIBLE

159138import Data.Coerce (Coercible, coerce)

139+coerce' :: Coercible a b => a -> b

140+coerce' = coerce

141+#else

142+coerce' :: a -> b

143+coerce' = unsafeCoerce

144+#endif

160145

161146parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

162147parseIndexedJSON p idx value = p value <?> Index idx

@@ -165,7 +150,7 @@ parseIndexedJSON p idx value = p value <?> Index idx

165150parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)

166151parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx

167152 where

168− p = withArray "(k, v)" $ \ab ->

153+ p = withArray "(k,v)" $ \ab ->

169154 let n = V.length ab

170155 in if n == 2

171156 then (,) <$> parseJSONElemAtIndex keyParser 0 ab

@@ -177,34 +162,43 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx

177162parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a

178163parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx

179164

165+scientificToNumber :: Scientific -> Number

166+scientificToNumber s

167+ | e < 0 = D $ Scientific.toRealFloat s

168+ | otherwise = I $ c * 10 ^ e

169+ where

170+ e = Scientific.base10Exponent s

171+ c = Scientific.coefficient s

172+{-# INLINE scientificToNumber #-}

173+

180174parseRealFloat :: RealFloat a => String -> Value -> Parser a

181−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s

182−parseRealFloat _ Null = pure (0/0)

183−parseRealFloat name v = prependContext name (unexpected v)

175+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s

176+parseRealFloat _ Null = pure (0/0)

177+parseRealFloat expected v = typeMismatch expected v

184178{-# INLINE parseRealFloat #-}

185179

186−parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a

187−parseIntegralFromScientific s =

180+parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a

181+parseIntegralFromScientific expected s =

188182 case Scientific.floatingOrInteger s :: Either Double a of

189183 Right x -> pure x

190− Left _ -> fail $ "unexpected floating number " ++ show s

184+ Left _ -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s

191185{-# INLINE parseIntegralFromScientific #-}

192186

193187parseIntegral :: Integral a => String -> Value -> Parser a

194−parseIntegral name =

195− prependContext name . withBoundedScientific' parseIntegralFromScientific

188+parseIntegral expected =

189+ withScientific expected $ parseIntegralFromScientific expected

196190{-# INLINE parseIntegral #-}

197191

198−parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a

199−parseBoundedIntegralFromScientific s = maybe

200− (fail $ "value is either floating or will cause over or underflow " ++ show s)

192+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a

193+parseBoundedIntegralFromScientific expected s = maybe

194+ (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)

201195 pure

202196 (Scientific.toBoundedInteger s)

203197{-# INLINE parseBoundedIntegralFromScientific #-}

204198

205199parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a

206−parseBoundedIntegral name =

207− prependContext name . withScientific' parseBoundedIntegralFromScientific

200+parseBoundedIntegral expected =

201+ withScientific expected $ parseBoundedIntegralFromScientific expected

208202{-# INLINE parseBoundedIntegral #-}

209203

210204parseScientificText :: Text -> Parser Scientific

@@ -214,20 +208,13 @@ parseScientificText

214208 . T.encodeUtf8

215209

216210parseIntegralText :: Integral a => String -> Text -> Parser a

217−parseIntegralText name t =

218− prependContext name $

219− parseScientificText t

220− >>= rejectLargeExponent

221− >>= parseIntegralFromScientific

222− where

223− rejectLargeExponent :: Scientific -> Parser Scientific

224− rejectLargeExponent s = withBoundedScientific' pure (Number s)

211+parseIntegralText expected t =

212+ parseScientificText t >>= parseIntegralFromScientific expected

225213{-# INLINE parseIntegralText #-}

226214

227215parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a

228−parseBoundedIntegralText name t =

229− prependContext name $

230− parseScientificText t >>= parseBoundedIntegralFromScientific

216+parseBoundedIntegralText expected t =

217+ parseScientificText t >>= parseBoundedIntegralFromScientific expected

231218

232219parseOptionalFieldWith :: (Value -> Parser (Maybe a))

233220 -> Object -> Text -> Parser (Maybe a)

@@ -287,21 +274,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

287274--

288275-- The basic ways to signal a failed conversion are as follows:

289276--

290−-- * 'fail' yields a custom error message: it is the recommended way of

291−-- reporting a failure;

292−--

293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:

294−-- use it when the error is meant to be caught by some @('<|>')@;

277+-- * 'empty' and 'mzero' work, but are terse and uninformative

295278--

296−-- * 'typeMismatch' can be used to report a failure when the encountered value

297−-- is not of the expected JSON type; 'unexpected' is an appropriate alternative

298−-- when more than one type may be expected, or to keep the expected type

299−-- implicit.

279+-- * 'fail' yields a custom error message

300280--

301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's

302−-- error messages.

281+-- * 'typeMismatch' produces an informative message for cases when the

282+-- value encountered is not of the expected type

303283--

304−-- An example type and instance using 'typeMismatch' and 'prependFailure':

284+-- An example type and instance:

305285--

306286-- @

307287-- \-- Allow ourselves to write 'Text' literals.

@@ -309,30 +289,15 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

309289--

310290-- data Coord = Coord { x :: Double, y :: Double }

311291--

312−-- instance 'FromJSON' Coord where

313−-- 'parseJSON' ('Object' v) = Coord

314−-- '<$>' v '.:' \"x\"

315−-- '<*>' v '.:' \"y\"

316−--

317−-- \-- We do not expect a non-'Object' value here.

318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'

319−-- \-- gives a much more informative error message.

320−-- 'parseJSON' invalid =

321−-- 'prependFailure' "parsing Coord failed, "

322−-- ('typeMismatch' \"Object\" invalid)

323−-- @

324−--

325−-- For this common case of only being concerned with a single

326−-- type of JSON value, the functions 'withObject', 'withScientific', etc.

327−-- are provided. Their use is to be preferred when possible, since

328−-- they are more terse. Using 'withObject', we can rewrite the above instance

329−-- (assuming the same language extension and data type) as:

292+-- instance FromJSON Coord where

293+-- parseJSON ('Object' v) = Coord '<$>'

294+-- v '.:' \"x\" '<*>'

295+-- v '.:' \"y\"

330296--

331−-- @

332−-- instance 'FromJSON' Coord where

333−-- 'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord

334−-- '<$>' v '.:' \"x\"

335−-- '<*>' v '.:' \"y\"

297+-- \-- We do not expect a non-'Object' value here.

298+-- \-- We could use 'mzero' to fail, but 'typeMismatch'

299+-- \-- gives a much more informative error message.

300+-- parseJSON invalid = 'typeMismatch' \"Coord\" invalid

336301-- @

337302--

338303-- Instead of manually writing your 'FromJSON' instance, there are two options

@@ -340,7 +305,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

340305--

341306-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

342307-- instance at compile time. The generated instance is optimized for your type

343−-- so it will probably be more efficient than the following option.

308+-- so will probably be more efficient than the following two options:

344309--

345310-- * The compiler can provide a default generic implementation for

346311-- 'parseJSON'.

@@ -358,21 +323,18 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

358323--

359324-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'

360325--

361−-- instance 'FromJSON' Coord

326+-- instance FromJSON Coord

362327-- @

363328--

364−-- The default implementation will be equivalent to

365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different

366−-- options, you can customize the generic decoding by defining:

329+-- If @DefaultSignatures@ doesn't give exactly the results you want,

330+-- you can customize the generic decoding with only a tiny amount of

331+-- effort, using 'genericParseJSON' with your preferred 'Options':

367332--

368333-- @

369−-- customOptions = 'defaultOptions'

370−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

371−-- }

372−--

373−-- instance 'FromJSON' Coord where

374−-- 'parseJSON' = 'genericParseJSON' customOptions

334+-- instance FromJSON Coord where

335+-- parseJSON = 'genericParseJSON' 'defaultOptions'

375336-- @

337+

376338class FromJSON a where

377339 parseJSON :: Value -> Parser a

378340

@@ -380,11 +342,13 @@ class FromJSON a where

380342 parseJSON = genericParseJSON defaultOptions

381343

382344 parseJSONList :: Value -> Parser [a]

383− parseJSONList = withArray "[]" $ \a ->

384− zipWithM (parseIndexedJSON parseJSON) [0..]

345+ parseJSONList (Array a)

346+ = zipWithM (parseIndexedJSON parseJSON) [0..]

385347 . V.toList

386348 $ a

387349

350+ parseJSONList v = typeMismatch "[a]" v

351+

388352-------------------------------------------------------------------------------

389353-- Classes and types for map keys

390354-------------------------------------------------------------------------------

@@ -396,16 +360,6 @@ class FromJSON a where

396360-- > newtype SomeId = SomeId { getSomeId :: Text }

397361-- > deriving (Eq,Ord,Hashable,FromJSONKey)

398362--

399−-- If you have a sum of nullary constructors, you may use the generic

400−-- implementation:

401−--

402−-- @

403−-- data Color = Red | Green | Blue

404−-- deriving Generic

405−--

406−-- instance 'FromJSONKey' Color where

407−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

408−-- @

409363class FromJSONKey a where

410364 -- | Strategy for parsing the key of a map-like container.

411365 fromJSONKey :: FromJSONKeyFunction a

@@ -428,7 +382,11 @@ class FromJSONKey a where

428382-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

429383-- can be inspected, but cannot be constructed.

430384data CoerceText a where

385+#if HAS_COERCIBLE

431386 CoerceText :: Coercible Text a => CoerceText a

387+#else

388+ CoerceText :: CoerceText a

389+#endif

432390

433391-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

434392-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

@@ -448,7 +406,7 @@ data FromJSONKeyFunction a

448406

449407-- | Only law abiding up to interpretation

450408instance Functor FromJSONKeyFunction where

451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)

409+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

452410 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

453411 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

454412 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

@@ -462,7 +420,9 @@ instance Functor FromJSONKeyFunction where

462420--

463421-- On pre GHC 7.8 this is unconstrainted function.

464422fromJSONKeyCoerce ::

423+#if HAS_COERCIBLE

465424 Coercible Text a =>

425+#endif

466426 FromJSONKeyFunction a

467427fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

468428

@@ -470,91 +430,60 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

470430--

471431-- See note on 'fromJSONKeyCoerce'.

472432coerceFromJSONKeyFunction ::

433+#if HAS_COERCIBLE

473434 Coercible a b =>

435+#endif

474436 FromJSONKeyFunction a -> FromJSONKeyFunction b

437+#if HAS_COERCIBLE

475438coerceFromJSONKeyFunction = coerce

439+#else

440+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

441+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

442+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

443+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

444+#endif

476445

477446{-# RULES

478447 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

479448 fmap id x = x

480449 #-}

450+#if HAS_COERCIBLE

481451{-# RULES

482452 "FromJSONKeyCoerce: fmap coerce" forall x .

483453 fmap coerce x = coerceFromJSONKeyFunction x

484454 #-}

455+#endif

485456

486457-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

487458mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

488459mapFromJSONKeyFunction = fmap

489460

490−-- | 'fromJSONKey' for 'Generic' types.

491−-- These types must be sums of nullary constructors, whose names will be used

492−-- as keys for JSON objects.

493−--

494−-- See also 'genericToJSONKey'.

495−--

496−-- === __Example__

497−--

498−-- @

499−-- data Color = Red | Green | Blue

500−-- deriving 'Generic'

501−--

502−-- instance 'FromJSONKey' Color where

503−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

504−-- @

505−genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))

506− => JSONKeyOptions

507− -> FromJSONKeyFunction a

508−genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->

509− case parseSumFromString (keyModifier opts) t of

510− Nothing -> fail $

511− "invalid key " ++ show t ++ ", expected one of " ++ show cnames

512− Just k -> pure (to k)

513− where

514− cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])

515−

516−class (ConstructorNames f, SumFromString f) => GFromJSONKey f where

517−instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where

518−

519461-------------------------------------------------------------------------------

520462-- Functions needed for documentation

521463-------------------------------------------------------------------------------

522464

523465-- | Fail parsing due to a type mismatch, with a descriptive message.

524466--

525−-- The following wrappers should generally be prefered:

526−-- 'withObject', 'withArray', 'withText', 'withBool'.

527−--

528−-- ==== Error message example

467+-- Example usage:

529468--

530−-- > typeMismatch "Object" (String "oops")

531−-- > -- Error: "expected Object, but encountered String"

532−typeMismatch :: String -- ^ The name of the JSON type being parsed

533− -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,

534− -- @\"Boolean\"@, or @\"Null\"@).

469+-- @

470+-- instance FromJSON Coord where

471+-- parseJSON ('Object' v) = {- type matches, life is good -}

472+-- parseJSON wat = 'typeMismatch' \"Coord\" wat

473+-- @

474+typeMismatch :: String -- ^ The name of the type you are trying to parse.

535475 -> Value -- ^ The actual value encountered.

536476 -> Parser a

537477typeMismatch expected actual =

538− fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual

539−

540−-- | Fail parsing due to a type mismatch, when the expected types are implicit.

541−--

542−-- ==== Error message example

543−--

544−-- > unexpected (String "oops")

545−-- > -- Error: "unexpected String"

546−unexpected :: Value -> Parser a

547−unexpected actual = fail $ "unexpected " ++ typeOf actual

548−

549−-- | JSON type of a value, name of the head constructor.

550−typeOf :: Value -> String

551−typeOf v = case v of

552− Object _ -> "Object"

553− Array _ -> "Array"

554− String _ -> "String"

555− Number _ -> "Number"

556− Bool _ -> "Boolean"

557− Null -> "Null"

478+ fail $ "expected " ++ expected ++ ", encountered " ++ name

479+ where

480+ name = case actual of

481+ Object _ -> "Object"

482+ Array _ -> "Array"

483+ String _ -> "String"

484+ Number _ -> "Number"

485+ Bool _ -> "Boolean"

486+ Null -> "Null"

558487

559488-------------------------------------------------------------------------------

560489-- Lifings of FromJSON and ToJSON to unary and binary type constructors

@@ -567,7 +496,7 @@ typeOf v = case v of

567496--

568497-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

569498-- instance at compile time. The generated instance is optimized for your type

570−-- so it will probably be more efficient than the following option.

499+-- so will probably be more efficient than the following two options:

571500--

572501-- * The compiler can provide a default generic implementation for

573502-- 'liftParseJSON'.

@@ -585,20 +514,16 @@ typeOf v = case v of

585514--

586515-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'

587516--

588−-- instance 'FromJSON' a => 'FromJSON1' (Pair a)

517+-- instance FromJSON a => FromJSON1 (Pair a)

589518-- @

590519--

591−-- If the default implementation doesn't give exactly the results you want,

520+-- If @DefaultSignatures@ doesn't give exactly the results you want,

592521-- you can customize the generic decoding with only a tiny amount of

593522-- effort, using 'genericLiftParseJSON' with your preferred 'Options':

594523--

595524-- @

596−-- customOptions = 'defaultOptions'

597−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

598−-- }

599−--

600−-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where

601−-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions

525+-- instance FromJSON a => FromJSON1 (Pair a) where

526+-- liftParseJSON = 'genericLiftParseJSON' 'defaultOptions'

602527-- @

603528class FromJSON1 f where

604529 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)

@@ -635,8 +560,9 @@ class FromJSON2 f where

635560 -> (Value -> Parser b)

636561 -> (Value -> Parser [b])

637562 -> Value -> Parser [f a b]

638− liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->

639− fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)

563+ liftParseJSONList2 fa ga fb gb v = case v of

564+ Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)

565+ _ -> typeMismatch "[a]" v

640566

641567-- | Lift the standard 'parseJSON' function through the type constructor.

642568parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)

@@ -650,7 +576,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList

650576-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.

651577listParser :: (Value -> Parser a) -> Value -> Parser [a]

652578listParser f (Array xs) = fmap V.toList (V.mapM f xs)

653−listParser _ v = typeMismatch "Array" v

579+listParser _ v = typeMismatch "[a]" v

654580{-# INLINE listParser #-}

655581

656582-------------------------------------------------------------------------------

@@ -668,139 +594,48 @@ instance (FromJSON a) => FromJSON [a] where

668594-- Functions

669595-------------------------------------------------------------------------------

670596

671−-- | Add context to a failure message, indicating the name of the structure

672−-- being parsed.

673−--

674−-- > prependContext "MyType" (fail "[error message]")

675−-- > -- Error: "parsing MyType failed, [error message]"

676−prependContext :: String -> Parser a -> Parser a

677−prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")

678−

679−-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@

680−-- is an 'Data.Aeson.Object' and fails otherwise.

681−--

682−-- ==== Error message example

683−--

684−-- > withObject "MyType" f (String "oops")

685−-- > -- Error: "parsing MyType failed, expected Object, but encountered String"

597+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@

598+-- and fails using @'typeMismatch' expected@ otherwise.

686599withObject :: String -> (Object -> Parser a) -> Value -> Parser a

687−withObject _ f (Object obj) = f obj

688−withObject name _ v = prependContext name (typeMismatch "Object" v)

600+withObject _ f (Object obj) = f obj

601+withObject expected _ v = typeMismatch expected v

689602{-# INLINE withObject #-}

690603

691−-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a

692−-- 'Data.Aeson.String' and fails otherwise.

693−--

694−-- ==== Error message example

695−--

696−-- > withText "MyType" f Null

697−-- > -- Error: "parsing MyType failed, expected String, but encountered Null"

604+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@

605+-- and fails using @'typeMismatch' expected@ otherwise.

698606withText :: String -> (Text -> Parser a) -> Value -> Parser a

699−withText _ f (String txt) = f txt

700−withText name _ v = prependContext name (typeMismatch "String" v)

607+withText _ f (String txt) = f txt

608+withText expected _ v = typeMismatch expected v

701609{-# INLINE withText #-}

702610

703−-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is

704−-- an 'Data.Aeson.Array' and fails otherwise.

705−--

706−-- ==== Error message example

707−--

708−-- > withArray "MyType" f (String "oops")

709−-- > -- Error: "parsing MyType failed, expected Array, but encountered String"

611+-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@

612+-- and fails using @'typeMismatch' expected@ otherwise.

710613withArray :: String -> (Array -> Parser a) -> Value -> Parser a

711−withArray _ f (Array arr) = f arr

712−withArray name _ v = prependContext name (typeMismatch "Array" v)

614+withArray _ f (Array arr) = f arr

615+withArray expected _ v = typeMismatch expected v

713616{-# INLINE withArray #-}

714617

715−-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number

716−-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'

717−-- otherwise.

718−--

719−-- /Warning/: If you are converting from a scientific to an unbounded

720−-- type such as 'Integer' you may want to add a restriction on the

721−-- size of the exponent (see 'withBoundedScientific') to prevent

722−-- malicious input from filling up the memory of the target system.

723−--

724−-- ==== Error message example

725−--

726−-- > withScientific "MyType" f (String "oops")

727−-- > -- Error: "parsing MyType failed, expected Number, but encountered String"

618+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.

619+-- and fails using @'typeMismatch' expected@ otherwise.

620+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a

621+withNumber expected f = withScientific expected (f . scientificToNumber)

622+{-# INLINE withNumber #-}

623+{-# DEPRECATED withNumber "Use withScientific instead" #-}

624+

625+-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.

626+-- and fails using @'typeMismatch' expected@ otherwise.

728627withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a

729−withScientific _ f (Number scientific) = f scientific

730−withScientific name _ v = prependContext name (typeMismatch "Number" v)

628+withScientific _ f (Number scientific) = f scientific

629+withScientific expected _ v = typeMismatch expected v

731630{-# INLINE withScientific #-}

732631

733−-- | A variant of 'withScientific' which doesn't use 'prependContext', so that

734−-- such context can be added separately in a way that also applies when the

735−-- continuation @f :: Scientific -> Parser a@ fails.

736−--

737−-- /Warning/: If you are converting from a scientific to an unbounded

738−-- type such as 'Integer' you may want to add a restriction on the

739−-- size of the exponent (see 'withBoundedScientific') to prevent

740−-- malicious input from filling up the memory of the target system.

741−--

742−-- ==== Error message examples

743−--

744−-- > withScientific' f (String "oops")

745−-- > -- Error: "unexpected String"

746−-- >

747−-- > prependContext "MyType" (withScientific' f (String "oops"))

748−-- > -- Error: "parsing MyType failed, unexpected String"

749−withScientific' :: (Scientific -> Parser a) -> Value -> Parser a

750−withScientific' f v = case v of

751− Number n -> f n

752− _ -> typeMismatch "Number" v

753−{-# INLINE withScientific' #-}

754−

755−-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number

756−-- when @value@ is a 'Number' with exponent less than or equal to 1024.

757−withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a

758−withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v

759−{-# INLINE withBoundedScientific #-}

760−

761−-- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',

762−-- so that such context can be added separately in a way that also applies

763−-- when the continuation @f :: Scientific -> Parser a@ fails.

764−withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a

765−withBoundedScientific' f v = withBoundedScientific_ id f v

766−{-# INLINE withBoundedScientific' #-}

767−

768−-- | A variant of 'withBoundedScientific_' parameterized by a function to apply

769−-- to the 'Parser' in case of failure.

770−withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a

771−withBoundedScientific_ whenFail f (Number scientific) =

772− if exp10 > 1024

773− then whenFail (fail msg)

774− else f scientific

775− where

776− exp10 = base10Exponent scientific

777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"

778−withBoundedScientific_ whenFail _ v =

779− whenFail (typeMismatch "Number" v)

780−{-# INLINE withBoundedScientific_ #-}

781−

782−-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a

783−-- 'Boolean' and fails otherwise.

784−--

785−-- ==== Error message example

786−--

787−-- > withBool "MyType" f (String "oops")

788−-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"

632+-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@

633+-- and fails using @'typeMismatch' expected@ otherwise.

789634withBool :: String -> (Bool -> Parser a) -> Value -> Parser a

790−withBool _ f (Bool arr) = f arr

791−withBool name _ v = prependContext name (typeMismatch "Boolean" v)

635+withBool _ f (Bool arr) = f arr

636+withBool expected _ v = typeMismatch expected v

792637{-# INLINE withBool #-}

793638

794−-- | Decode a nested JSON-encoded string.

795−withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a

796−withEmbeddedJSON _ innerParser (String txt) =

797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)

798− where

799− eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON

800− eitherFormatError = either (Left . uncurry formatError) Right

801−withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)

802−{-# INLINE withEmbeddedJSON #-}

803−

804639-- | Convert a value from JSON, failing if the types do not match.

805640fromJSON :: (FromJSON a) => Value -> Result a

806641fromJSON = parse parseJSON

@@ -819,7 +654,9 @@ ifromJSON = iparse parseJSON

819654-- in an object for it to be valid. If the key and value are

820655-- optional, use '.:?' instead.

821656(.:) :: (FromJSON a) => Object -> Text -> Parser a

822−(.:) = explicitParseField parseJSON

657+obj .: key = case H.lookup key obj of

658+ Nothing -> fail $ "key " ++ show key ++ " not present"

659+ Just v -> parseJSON v <?> Key key

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

824661

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

@@ -830,7 +667,9 @@ ifromJSON = iparse parseJSON

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

831668-- value are mandatory, use '.:' instead.

832669(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

833−(.:?) = explicitParseFieldMaybe parseJSON

670+obj .:? key = case H.lookup key obj of

671+ Nothing -> pure Nothing

672+ Just v -> parseJSON v <?> Key key

834673{-# INLINE (.:?) #-}

835674

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

@@ -840,47 +679,11 @@ ifromJSON = iparse parseJSON

840679-- This differs from '.:?' by attempting to parse 'Null' the same as any

841680-- other JSON value, instead of interpreting it as 'Nothing'.

842681(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

843−(.:!) = explicitParseFieldMaybe' parseJSON

682+obj .:! key = case H.lookup key obj of

683+ Nothing -> pure Nothing

684+ Just v -> Just <$> parseJSON v <?> Key key

844685{-# INLINE (.:!) #-}

845686

846−-- | Function variant of '.:'.

847−parseField :: (FromJSON a) => Object -> Text -> Parser a

848−parseField = (.:)

849−{-# INLINE parseField #-}

850−

851−-- | Function variant of '.:?'.

852−parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

853−parseFieldMaybe = (.:?)

854−{-# INLINE parseFieldMaybe #-}

855−

856−-- | Function variant of '.:!'.

857−parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

858−parseFieldMaybe' = (.:!)

859−{-# INLINE parseFieldMaybe' #-}

860−

861−-- | Variant of '.:' with explicit parser function.

862−--

863−-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

864−explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

865−explicitParseField p obj key = case H.lookup key obj of

866− Nothing -> fail $ "key " ++ show key ++ " not found"

867− Just v -> p v <?> Key key

868−{-# INLINE explicitParseField #-}

869−

870−-- | Variant of '.:?' with explicit parser function.

871−explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)

872−explicitParseFieldMaybe p obj key = case H.lookup key obj of

873− Nothing -> pure Nothing

874− Just v -> liftParseJSON p (listParser p) v <?> Key key -- listParser isn't used by maybe instance.

875−{-# INLINE explicitParseFieldMaybe #-}

876−

877−-- | Variant of '.:!' with explicit parser function.

878−explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)

879−explicitParseFieldMaybe' p obj key = case H.lookup key obj of

880− Nothing -> pure Nothing

881− Just v -> Just <$> p v <?> Key key

882−{-# INLINE explicitParseFieldMaybe' #-}

883−

884687-- | Helper for use in combination with '.:?' to provide default

885688-- values for optional JSON object fields.

886689--

@@ -903,47 +706,11 @@ pmval .!= val = fromMaybe val <$> pmval

903706-- Generic parseJSON

904707-------------------------------------------------------------------------------

905708

906−instance GFromJSON arity V1 where

907− -- Whereof we cannot format, thereof we cannot parse:

908− gParseJSON _ _ _ = fail "Attempted to parse empty type"

909−

910−

911709instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where

912710 -- Meta-information, which is not handled elsewhere, is just added to the

913711 -- parsed value:

914712 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs

915713

916−-- Information for error messages

917−

918−type TypeName = String

919−type ConName = String

920−

921−-- | Add the name of the type being parsed to a parser's error messages.

922−contextType :: TypeName -> Parser a -> Parser a

923−contextType = prependContext

924−

925−-- | Add the tagKey that will be looked up while building an ADT

926−-- | Produce the error equivalent to

927−-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and

928−-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],

929−-- | The parser returned error was: could not find key "tag"

930−contextTag :: Text -> [String] -> Parser a -> Parser a

931−contextTag tagKey cnames = prependFailure

932− ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++

933− " containing one of " ++ show cnames ++ ", ")

934−

935−-- | Add the name of the constructor being parsed to a parser's error messages.

936−contextCons :: ConName -> TypeName -> Parser a -> Parser a

937−contextCons cname tname = prependContext (showCons cname tname)

938−

939−-- | Render a constructor as @\"MyType(MyConstructor)\"@.

940−showCons :: ConName -> TypeName -> String

941−showCons cname tname = tname ++ "(" ++ cname ++ ")"

942−

943−--------------------------------------------------------------------------------

944−

945−-- Parsing single fields

946−

947714instance (FromJSON a) => GFromJSON arity (K1 i a) where

948715 -- Constant values are decoded using their FromJSON instance:

949716 gParseJSON _opts _ = fmap K1 . parseJSON

@@ -958,499 +725,326 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where

958725 -- FromJSON1 instance:

959726 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl

960727

728+instance GFromJSON arity U1 where

729+ -- Empty constructors are expected to be encoded as an empty array:

730+ gParseJSON _opts _ v

731+ | isEmptyArray v = pure U1

732+ | otherwise = typeMismatch "unit constructor (U1)" v

733+

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

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

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

737+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs

738+

739+instance ( FromProduct arity a, FromProduct arity b

740+ , ProductSize a, ProductSize b

741+ ) => GFromJSON arity (a :*: b) where

742+ -- Products are expected to be encoded to an array. Here we check whether we

743+ -- got an array of the same size as the product, then parse each of the

744+ -- product's elements using parseProduct:

745+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->

746+ let lenArray = V.length arr

747+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

748+ productSize in

749+ if lenArray == lenProduct

750+ then parseProduct opts fargs arr 0 lenProduct

751+ else fail $ "When expecting a product of " ++ show lenProduct ++

752+ " values, encountered an Array of " ++ show lenArray ++

753+ " elements instead"

754+

755+instance ( AllNullary (a :+: b) allNullary

756+ , ParseSum arity (a :+: b) allNullary

757+ ) => GFromJSON arity (a :+: b) where

758+ -- If all constructors of a sum datatype are nullary and the

759+ -- 'allNullaryToStringTag' option is set they are expected to be

760+ -- encoded as strings. This distinction is made by 'parseSum':

761+ gParseJSON opts fargs =

762+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->

763+ Parser ((a :+: b) d))

764+ . parseSum opts fargs

765+

961766instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where

962767 -- If an occurrence of the last type parameter is nested inside two

963768 -- composed types, it is decoded by using the outermost type's FromJSON1

964769 -- instance to generically decode the innermost type:

965770 gParseJSON opts fargs =

966− let gpj = gParseJSON opts fargs in

967− fmap Comp1 . liftParseJSON gpj (listParser gpj)

968−

969−--------------------------------------------------------------------------------

970−

971−instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where

972− -- Meta-information, which is not handled elsewhere, is just added to the

973− -- parsed value:

974− gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)

975− where

976− tname = moduleName proxy ++ "." ++ datatypeName proxy

977− proxy = undefined :: M1 _i d _f _p

978−

979−-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data

980−-- type's name.

981−class GFromJSON' arity f where

982− gParseJSON' :: TypeName :* Options :* FromArgs arity a

983− -> Value

984− -> Parser (f a)

985−

986−-- | Single constructor.

987−instance ( ConsFromJSON arity a

988− , AllNullary (C1 c a) allNullary

989− , ParseSum arity (C1 c a) allNullary

990− , Constructor c

991− ) => GFromJSON' arity (C1 c a) where

992− -- The option 'tagSingleConstructors' determines whether to wrap

993− -- a single-constructor type.

994− gParseJSON' p@(_ :* opts :* _)

995− | tagSingleConstructors opts

996− = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))

997− . parseSum p

998− | otherwise = fmap M1 . consParseJSON (cname :* p)

999− where

1000− cname = conName (undefined :: M1 _i c _f _p)

1001−

1002−-- | Multiple constructors.

1003−instance ( AllNullary (a :+: b) allNullary

1004− , ParseSum arity (a :+: b) allNullary

1005− ) => GFromJSON' arity (a :+: b) where

1006− -- If all constructors of a sum datatype are nullary and the

1007− -- 'allNullaryToStringTag' option is set they are expected to be

1008− -- encoded as strings. This distinction is made by 'parseSum':

1009− gParseJSON' p =

1010− (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->

1011− Parser ((a :+: b) _d))

1012− . parseSum p

771+ let gpj = gParseJSON opts fargs in

772+ fmap Comp1 . liftParseJSON gpj (listParser gpj)

1013773

1014774--------------------------------------------------------------------------------

1015775

1016776class ParseSum arity f allNullary where

1017− parseSum :: TypeName :* Options :* FromArgs arity a

1018− -> Value

1019− -> Tagged allNullary (Parser (f a))

1020−

1021−instance ( ConstructorNames f

1022− , SumFromString f

1023− , FromPair arity f

1024− , FromTaggedObject arity f

1025− , FromUntaggedValue arity f

1026− ) => ParseSum arity f True where

1027− parseSum p@(tname :* opts :* _)

1028− | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts

1029− | otherwise = Tagged . parseNonAllNullarySum p

1030−

1031−instance ( ConstructorNames f

1032− , FromPair arity f

1033− , FromTaggedObject arity f

1034− , FromUntaggedValue arity f

1035− ) => ParseSum arity f False where

1036− parseSum p = Tagged . parseNonAllNullarySum p

777+ parseSum :: Options -> FromArgs arity a

778+ -> Value -> Tagged allNullary (Parser (f a))

779+

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

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

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

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

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

785+ parseSum opts fargs

786+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

787+ | otherwise = Tagged . parseNonAllNullarySum opts fargs

788+

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

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

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

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

793+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

1037794

1038795--------------------------------------------------------------------------------

1039796

1040−parseAllNullarySum :: (SumFromString f, ConstructorNames f)

1041− => TypeName -> Options -> Value -> Parser (f a)

1042−parseAllNullarySum tname opts =

1043− withText tname $ \tag ->

1044− maybe (badTag tag) return $

1045− parseSumFromString modifier tag

1046− where

1047− badTag tag = failWithCTags tname modifier $ \cnames ->

1048− "expected one of the tags " ++ show cnames ++

1049− ", but found tag " ++ show tag

1050− modifier = constructorTagModifier opts

1051−

1052−-- | Fail with an informative error message about a mismatched tag.

1053−-- The error message is parameterized by the list of expected tags,

1054−-- to be inferred from the result type of the parser.

1055−failWithCTags

1056− :: forall f a t. ConstructorNames f

1057− => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)

1058−failWithCTags tname modifier f =

1059− contextType tname . fail $ f cnames

1060− where

1061− cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])

797+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)

798+parseAllNullarySum opts = withText "Text" $ \key ->

799+ maybe (notFound key) return $

800+ parseSumFromString opts key

1062801

1063802class SumFromString f where

1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)

803+ parseSumFromString :: Options -> Text -> Maybe (f a)

1065804

1066805instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

1067806 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

1068807 (R1 <$> parseSumFromString opts key)

1069808

1070809instance (Constructor c) => SumFromString (C1 c U1) where

1071− parseSumFromString modifier key

1072− | key == name = Just $ M1 U1

1073− | otherwise = Nothing

1074− where

1075− name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)

1076−

1077−-- For genericFromJSONKey

1078−instance SumFromString a => SumFromString (D1 d a) where

1079− parseSumFromString modifier key = M1 <$> parseSumFromString modifier key

1080−

1081−-- | List of all constructor tags.

1082−constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]

1083−constructorTags modifier =

1084− fmap DList.toList (constructorNames' modifier)

1085−

1086−-- | List of all constructor names of an ADT, after a given conversion

1087−-- function. (Better inlining.)

1088−class ConstructorNames a where

1089− constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)

1090−

1091−instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where

1092− constructorNames' = liftA2 append constructorNames' constructorNames'

1093− where

1094− append

1095− :: Tagged2 a (DList.DList t)

1096− -> Tagged2 b (DList.DList t)

1097− -> Tagged2 (a :+: b) (DList.DList t)

1098− append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)

1099−

1100−instance Constructor c => ConstructorNames (C1 c a) where

1101− constructorNames' f = Tagged2 (pure (f cname))

1102− where

1103− cname = conName (undefined :: M1 _i c _f _p)

1104−

1105−-- For genericFromJSONKey

1106−instance ConstructorNames a => ConstructorNames (D1 d a) where

1107− constructorNames' = retag . constructorNames'

1108− where

1109− retag :: Tagged2 a u -> Tagged2 (D1 d a) u

1110− retag (Tagged2 x) = Tagged2 x

810+ parseSumFromString opts key | key == name = Just $ M1 U1

811+ | otherwise = Nothing

812+ where

813+ name = pack $ constructorTagModifier opts $

814+ conName (undefined :: t c U1 p)

1111815

1112816--------------------------------------------------------------------------------

1113−parseNonAllNullarySum :: forall f c arity.

1114− ( FromPair arity f

1115− , FromTaggedObject arity f

1116− , FromUntaggedValue arity f

1117− , ConstructorNames f

1118− ) => TypeName :* Options :* FromArgs arity c

1119− -> Value -> Parser (f c)

1120−parseNonAllNullarySum p@(tname :* opts :* _) =

817+

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

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

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

821+ ) => Options -> FromArgs arity c

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

823+parseNonAllNullarySum opts fargs =

1121824 case sumEncoding opts of

1122825 TaggedObject{..} ->

1123− withObject tname $ \obj -> do

1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey

1125− fromMaybe (badTag tag <?> Key tagKey) $

1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj

1127− where

1128− tagKey = pack tagFieldName

1129− badTag tag = failWith_ $ \cnames ->

1130− "expected tag field to be one of " ++ show cnames ++

1131− ", but found tag " ++ show tag

1132− cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])

826+ withObject "Object" $ \obj -> do

827+ tag <- obj .: pack tagFieldName

828+ fromMaybe (notFound tag) $

829+ parseFromTaggedObject opts fargs contentsFieldName obj tag

1133830

1134831 ObjectWithSingleField ->

1135− withObject tname $ \obj -> case H.toList obj of

1136− [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $

1137− parsePair (tag :* p) v

1138− _ -> contextType tname . fail $

1139− "expected an Object with a single pair, but found " ++

1140− show (H.size obj) ++ " pairs"

1141− where

1142− badTag tag = failWith_ $ \cnames ->

1143− "expected an Object with a single pair where the tag is one of " ++

1144− show cnames ++ ", but found tag " ++ show tag

832+ withObject "Object" $ \obj ->

833+ case H.toList obj of

834+ [pair@(tag, _)] -> fromMaybe (notFound tag) $

835+ parsePair opts fargs pair

836+ _ -> fail "Object doesn't have a single field"

1145837

1146838 TwoElemArray ->

1147− withArray tname $ \arr -> case V.length arr of

1148− 2 | String tag <- V.unsafeIndex arr 0 ->

1149− maybe (badTag tag <?> Index 0) (<?> Index 1) $

1150− parsePair (tag :* p) (V.unsafeIndex arr 1)

1151− | otherwise ->

1152− contextType tname $

1153− fail "tag element is not a String" <?> Index 0

1154− len -> contextType tname . fail $

1155− "expected a 2-element Array, but encountered an Array of length " ++

1156− show len

1157− where

1158− badTag tag = failWith_ $ \cnames ->

1159− "expected tag of the 2-element Array to be one of " ++

1160− show cnames ++ ", but found tag " ++ show tag

839+ withArray "Array" $ \arr ->

840+ if V.length arr == 2

841+ then case V.unsafeIndex arr 0 of

842+ String tag -> fromMaybe (notFound tag) $

843+ parsePair opts fargs (tag, V.unsafeIndex arr 1)

844+ _ -> fail "First element is not a String"

845+ else fail "Array doesn't have 2 elements"

1161846

1162− UntaggedValue -> parseUntaggedValue p

1163− where

1164− failWith_ = failWithCTags tname (constructorTagModifier opts)

847+ UntaggedValue -> parseUntaggedValue opts fargs

1165848

1166849--------------------------------------------------------------------------------

1167850

1168851class FromTaggedObject arity f where

1169− -- The first two components of the parameter tuple are: the constructor tag

1170− -- to match against, and the contents field name.

1171− parseFromTaggedObject

1172− :: Text :* String :* TypeName :* Options :* FromArgs arity a

1173− -> Object

1174− -> Maybe (Parser (f a))

852+ parseFromTaggedObject :: Options -> FromArgs arity a

853+ -> String -> Object

854+ -> Text -> Maybe (Parser (f a))

1175855

1176856instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>

1177857 FromTaggedObject arity (a :+: b) where

1178− parseFromTaggedObject p obj =

1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>

1180− (fmap R1 <$> parseFromTaggedObject p obj)

858+ parseFromTaggedObject opts fargs contentsFieldName obj tag =

859+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>

860+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)

1181861

1182−instance ( IsRecord f isRecord

1183− , FromTaggedObject' arity f isRecord

862+instance ( FromTaggedObject' arity f

1184863 , Constructor c

1185864 ) => FromTaggedObject arity (C1 c f) where

1186− parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))

1187− | tag == tag'

1188− = Just . fmap M1 .

1189− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .

1190− parseFromTaggedObject' (contentsFieldName :* cname :* p)

1191− | otherwise = const Nothing

1192− where

1193− tag' = pack $ constructorTagModifier opts cname

1194− cname = conName (undefined :: M1 _i c _f _p)

865+ parseFromTaggedObject opts fargs contentsFieldName obj tag

866+ | tag == name = Just $ M1 <$> parseFromTaggedObject'

867+ opts fargs contentsFieldName obj

868+ | otherwise = Nothing

869+ where

870+ name = pack $ constructorTagModifier opts $

871+ conName (undefined :: t c f p)

1195872

1196873--------------------------------------------------------------------------------

1197874

1198−class FromTaggedObject' arity f isRecord where

1199− -- The first component of the parameter tuple is the contents field name.

1200− parseFromTaggedObject'

1201− :: String :* ConName :* TypeName :* Options :* FromArgs arity a

1202− -> Object -> Tagged isRecord (Parser (f a))

1203−

1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where

1205− -- Records are unpacked in the tagged object

1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)

1207−

1208−instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where

1209− -- Nonnullary nonrecords are encoded in the contents field

1210− parseFromTaggedObject' p obj = Tagged $ do

1211− contents <- contextCons cname tname (obj .: key)

1212− consParseJSON p' contents <?> Key key

1213− where

1214− key = pack contentsFieldName

1215− contentsFieldName :* p'@(cname :* tname :* _) = p

875+class FromTaggedObject' arity f where

876+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String

877+ -> Object -> Parser (f a)

878+

879+class FromTaggedObject'' arity f isRecord where

880+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String

881+ -> Object -> Tagged isRecord (Parser (f a))

1216882

1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where

1218− -- Nullary constructors don't need a contents field

1219− parseFromTaggedObject' _ _ = Tagged (pure U1)

883+instance ( IsRecord f isRecord

884+ , FromTaggedObject'' arity f isRecord

885+ ) => FromTaggedObject' arity f where

886+ parseFromTaggedObject' opts fargs contentsFieldName =

887+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .

888+ parseFromTaggedObject'' opts fargs contentsFieldName

889+

890+instance (FromRecord arity f) => FromTaggedObject'' arity f True where

891+ parseFromTaggedObject'' opts fargs _ =

892+ Tagged . parseRecord opts fargs Nothing

893+

894+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where

895+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .

896+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))

897+

898+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where

899+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)

1220900

1221901--------------------------------------------------------------------------------

1222902

1223−-- | Constructors need to be decoded differently depending on whether they're

1224−-- a record or not. This distinction is made by 'ConsParseJSON'.

1225903class ConsFromJSON arity f where

1226− consParseJSON

1227− :: ConName :* TypeName :* Options :* FromArgs arity a

1228− -> Value -> Parser (f a)

904+ consParseJSON :: Options -> FromArgs arity a

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

1229906

1230907class ConsFromJSON' arity f isRecord where

1231− consParseJSON'

1232− :: ConName :* TypeName :* Options :* FromArgs arity a

1233− -> Value -> Tagged isRecord (Parser (f a))

908+ consParseJSON' :: Options -> FromArgs arity a

909+ -> Maybe Text -- ^ A dummy label

910+ -- (Nothing to use proper label)

911+ -> Value -> Tagged isRecord (Parser (f a))

1234912

1235913instance ( IsRecord f isRecord

1236914 , ConsFromJSON' arity f isRecord

1237915 ) => ConsFromJSON arity f where

1238− consParseJSON p =

1239− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1240− . consParseJSON' p

1241−

1242−instance OVERLAPPING_

1243− ( GFromJSON arity a, RecordFromJSON arity (S1 s a)

1244− ) => ConsFromJSON' arity (S1 s a) True where

1245− consParseJSON' p@(cname :* tname :* opts :* fargs)

1246− | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs

1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

1248−

1249−instance RecordFromJSON arity f => ConsFromJSON' arity f True where

1250− consParseJSON' p@(cname :* tname :* _) =

1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

916+ consParseJSON opts fargs v = let

917+ (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of

918+ -- use a dummy object with a dummy label

919+ (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")

920+ _ ->(v,Nothing)

921+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

922+ $ consParseJSON' opts fargs lab v2

1252923

1253−instance OVERLAPPING_

1254− ConsFromJSON' arity U1 False where

1255− -- Empty constructors are expected to be encoded as an empty array:

1256− consParseJSON' (cname :* tname :* _) v =

1257− Tagged . contextCons cname tname $ case v of

1258− Array a | V.null a -> pure U1

1259− | otherwise -> fail_ a

1260− _ -> typeMismatch "Array" v

1261− where

1262− fail_ a = fail $

1263− "expected an empty Array, but encountered an Array of length " ++

1264− show (V.length a)

1265924

1266−instance OVERLAPPING_

1267− GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where

1268− consParseJSON' (_ :* _ :* opts :* fargs) =

1269− Tagged . fmap M1 . gParseJSON opts fargs

925+instance (FromRecord arity f) => ConsFromJSON' arity f True where

926+ consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"

927+ (parseRecord opts fargs mlab)

1270928

1271−instance (ProductFromJSON arity f, ProductSize f

1272− ) => ConsFromJSON' arity f False where

1273− consParseJSON' p = Tagged . productParseJSON0 p

929+instance (GFromJSON arity f) => ConsFromJSON' arity f False where

930+ consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs

1274931

1275932--------------------------------------------------------------------------------

1276933

1277−class FieldNames f where

1278− fieldNames :: f a -> [Text] -> [Text]

1279−

1280−instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where

1281− fieldNames _ =

1282− fieldNames (undefined :: a x) .

1283− fieldNames (undefined :: b y)

1284−

1285−instance (Selector s) => FieldNames (S1 s f) where

1286− fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)

934+class FromRecord arity f where

935+ parseRecord :: Options -> FromArgs arity a

936+ -> Maybe Text -- ^ A dummy label

937+ -- (Nothing to use proper label)

938+ -> Object -> Parser (f a)

1287939

1288−class RecordFromJSON arity f where

1289− recordParseJSON

1290− :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a

1291− -> Object -> Parser (f a)

1292−

1293−instance ( FieldNames f

1294− , RecordFromJSON' arity f

1295− ) => RecordFromJSON arity f where

1296− recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =

1297− \obj -> checkUnknown obj >> recordParseJSON' p obj

1298− where

1299− knownFields :: H.HashMap Text ()

1300− knownFields = H.fromList $ map (,()) $

1301− fieldNames (undefined :: f a)

1302− [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]

1303− checkUnknown =

1304− if not (rejectUnknownFields opts)

1305− then \_ -> return ()

1306− else \obj -> case H.keys (H.difference obj knownFields) of

1307− [] -> return ()

1308− unknownFields -> contextCons cname tname $

1309− fail ("unknown fields: " ++ show unknownFields)

1310−

1311−class RecordFromJSON' arity f where

1312− recordParseJSON'

1313− :: ConName :* TypeName :* Options :* FromArgs arity a

1314− -> Object -> Parser (f a)

1315−

1316−instance ( RecordFromJSON' arity a

1317− , RecordFromJSON' arity b

1318− ) => RecordFromJSON' arity (a :*: b) where

1319− recordParseJSON' p obj =

1320− (:*:) <$> recordParseJSON' p obj

1321− <*> recordParseJSON' p obj

940+instance ( FromRecord arity a

941+ , FromRecord arity b

942+ ) => FromRecord arity (a :*: b) where

943+ parseRecord opts fargs _ obj =

944+ (:*:) <$> parseRecord opts fargs Nothing obj

945+ <*> parseRecord opts fargs Nothing obj

1322946

1323947instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1324− RecordFromJSON' arity (S1 s a) where

1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do

1326− fv <- contextCons cname tname (obj .: label)

1327− M1 <$> gParseJSON opts fargs fv <?> Key label

1328− where

1329− label = pack $ fieldLabelModifier opts sname

1330− sname = selName (undefined :: M1 _i s _f _p)

1331−

1332−instance INCOHERENT_ (Selector s, FromJSON a) =>

1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where

1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label

1335− where

1336− label = fieldLabelModifier opts sname

1337− sname = selName (undefined :: M1 _i s _f _p)

948+ FromRecord arity (S1 s a) where

949+ parseRecord opts fargs lab =

950+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)

951+ where

952+ label = fromMaybe defLabel lab

953+ defLabel = pack . fieldLabelModifier opts $

954+ selName (undefined :: t s a p)

1338955

1339−-- Parse an Option like a Maybe.

1340956instance INCOHERENT_ (Selector s, FromJSON a) =>

1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where

1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj

1343− where

1344− wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1345− wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

957+ FromRecord arity (S1 s (K1 i (Maybe a))) where

958+ parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab

959+ parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label

960+ where

961+ label = fieldLabelModifier opts $

962+ selName (undefined :: t s (K1 i (Maybe a)) p)

1346963

1347964--------------------------------------------------------------------------------

1348965

1349−productParseJSON0

1350− :: forall f arity a. (ProductFromJSON arity f, ProductSize f)

1351− => ConName :* TypeName :* Options :* FromArgs arity a

1352− -> Value -> Parser (f a)

1353− -- Products are expected to be encoded to an array. Here we check whether we

1354− -- got an array of the same size as the product, then parse each of the

1355− -- product's elements using productParseJSON:

1356−productParseJSON0 p@(cname :* tname :* _ :* _) =

1357− withArray (showCons cname tname) $ \arr ->

1358− let lenArray = V.length arr

1359− lenProduct = (unTagged2 :: Tagged2 f Int -> Int)

1360− productSize in

1361− if lenArray == lenProduct

1362− then productParseJSON p arr 0 lenProduct

1363− else contextCons cname tname $

1364− fail $ "expected an Array of length " ++ show lenProduct ++

1365− ", but encountered an Array of length " ++ show lenArray

1366−

1367−--

1368−

1369−class ProductFromJSON arity f where

1370− productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a

966+class FromProduct arity f where

967+ parseProduct :: Options -> FromArgs arity a

1371968 -> Array -> Int -> Int

1372969 -> Parser (f a)

1373970

1374−instance ( ProductFromJSON arity a

1375− , ProductFromJSON arity b

1376− ) => ProductFromJSON arity (a :*: b) where

1377− productParseJSON p arr ix len =

1378− (:*:) <$> productParseJSON p arr ix lenL

1379− <*> productParseJSON p arr ixR lenR

971+instance ( FromProduct arity a

972+ , FromProduct arity b

973+ ) => FromProduct arity (a :*: b) where

974+ parseProduct opts fargs arr ix len =

975+ (:*:) <$> parseProduct opts fargs arr ix lenL

976+ <*> parseProduct opts fargs arr ixR lenR

1380977 where

1381978 lenL = len `unsafeShiftR` 1

1382979 ixR = ix + lenL

1383980 lenR = len - lenL

1384981

1385−instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where

1386− productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =

1387− M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix

982+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where

983+ parseProduct opts fargs arr ix _ =

984+ gParseJSON opts fargs $ V.unsafeIndex arr ix

1388985

1389986--------------------------------------------------------------------------------

1390987

1391988class FromPair arity f where

1392− -- The first component of the parameter tuple is the tag to match.

1393− parsePair :: Text :* TypeName :* Options :* FromArgs arity a

1394− -> Value

1395− -> Maybe (Parser (f a))

989+ parsePair :: Options -> FromArgs arity a

990+ -> Pair -> Maybe (Parser (f a))

1396991

1397992instance ( FromPair arity a

1398993 , FromPair arity b

1399994 ) => FromPair arity (a :+: b) where

1400− parsePair p pair =

1401− (fmap L1 <$> parsePair p pair) <|>

1402− (fmap R1 <$> parsePair p pair)

995+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>

996+ (fmap R1 <$> parsePair opts fargs pair)

1403997

1404998instance ( Constructor c

999+ , GFromJSON arity a

14051000 , ConsFromJSON arity a

14061001 ) => FromPair arity (C1 c a) where

1407− parsePair (tag :* p@(_ :* opts :* _)) v

1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v

1002+ parsePair opts fargs (tag, value)

1003+ | tag == tag' = Just $ gParseJSON opts fargs value

14091004 | otherwise = Nothing

1410− where

1411− tag' = pack $ constructorTagModifier opts cname

1412− cname = conName (undefined :: M1 _i c _a _p)

1005+ where

1006+ tag' = pack $ constructorTagModifier opts $

1007+ conName (undefined :: t c a p)

14131008

14141009--------------------------------------------------------------------------------

14151010

14161011class FromUntaggedValue arity f where

1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a

1418− -> Value

1419− -> Parser (f a)

1012+ parseUntaggedValue :: Options -> FromArgs arity a

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

14201014

14211015instance

14221016 ( FromUntaggedValue arity a

14231017 , FromUntaggedValue arity b

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

14251019 where

1426− parseUntaggedValue p value =

1427− L1 <$> parseUntaggedValue p value <|>

1428− R1 <$> parseUntaggedValue p value

1020+ parseUntaggedValue opts fargs value =

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

1022+ R1 <$> parseUntaggedValue opts fargs value

14291023

14301024instance OVERLAPPABLE_

1431− ( ConsFromJSON arity a

1432− , Constructor c

1025+ ( GFromJSON arity a

1026+ , ConsFromJSON arity a

14331027 ) => FromUntaggedValue arity (C1 c a)

14341028 where

1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)

1436− where

1437− cname = conName (undefined :: M1 _i c _f _p)

1029+ parseUntaggedValue = gParseJSON

14381030

14391031instance OVERLAPPING_

14401032 ( Constructor c )

14411033 => FromUntaggedValue arity (C1 c U1)

14421034 where

1443− parseUntaggedValue (tname :* opts :* _) v =

1444− contextCons cname tname $ case v of

1445− String tag

1446− | tag == tag' -> pure $ M1 U1

1447− | otherwise -> fail_ tag

1448− _ -> typeMismatch "String" v

1449− where

1450− tag' = pack $ constructorTagModifier opts cname

1451− cname = conName (undefined :: M1 _i c _f _p)

1452− fail_ tag = fail $

1453− "expected tag " ++ show tag' ++ ", but found tag " ++ show tag

1035+ parseUntaggedValue opts _ (String s)

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

1037+ pure $ M1 U1

1038+ | otherwise =

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

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

1041+

1042+

1043+--------------------------------------------------------------------------------

1044+

1045+notFound :: Text -> Parser a

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

1047+{-# INLINE notFound #-}

14541048

14551049-------------------------------------------------------------------------------

14561050-- Instances

@@ -1508,20 +1102,17 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where

15081102 parseJSON = parseJSON2

15091103 {-# INLINE parseJSON #-}

15101104

1511−instance FromJSON Void where

1512− parseJSON _ = fail "Cannot parse Void"

1513− {-# INLINE parseJSON #-}

1105+

15141106

15151107instance FromJSON Bool where

1516− parseJSON (Bool b) = pure b

1517− parseJSON v = typeMismatch "Bool" v

1108+ parseJSON = withBool "Bool" pure

15181109 {-# INLINE parseJSON #-}

15191110

15201111instance FromJSONKey Bool where

15211112 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of

15221113 "true" -> pure True

15231114 "false" -> pure False

1524− _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"

1115+ _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t

15251116

15261117instance FromJSON Ordering where

15271118 parseJSON = withText "Ordering" $ \s ->

@@ -1529,30 +1120,25 @@ instance FromJSON Ordering where

15291120 "LT" -> return LT

15301121 "EQ" -> return EQ

15311122 "GT" -> return GT

1532− _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++

1533− " (expected \"LT\", \"EQ\", or \"GT\")"

1123+ _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""

15341124

15351125instance FromJSON () where

15361126 parseJSON = withArray "()" $ \v ->

15371127 if V.null v

15381128 then pure ()

1539− else prependContext "()" $ fail "expected an empty array"

1129+ else fail "Expected an empty array"

15401130 {-# INLINE parseJSON #-}

15411131

15421132instance FromJSON Char where

1543− parseJSON = withText "Char" parseChar

1133+ parseJSON = withText "Char" $ \t ->

1134+ if T.compareLength t 1 == EQ

1135+ then pure $ T.head t

1136+ else fail "Expected a string of length 1"

15441137 {-# INLINE parseJSON #-}

15451138

1546− parseJSONList (String s) = pure (T.unpack s)

1547− parseJSONList v = typeMismatch "String" v

1139+ parseJSONList = withText "String" $ pure . T.unpack

15481140 {-# INLINE parseJSONList #-}

15491141

1550−parseChar :: Text -> Parser Char

1551−parseChar t =

1552− if T.compareLength t 1 == EQ

1553− then pure $ T.head t

1554− else prependContext "Char" $ fail "expected a string of length 1"

1555−

15561142instance FromJSON Double where

15571143 parseJSON = parseRealFloat "Double"

15581144 {-# INLINE parseJSON #-}

@@ -1564,6 +1150,12 @@ instance FromJSONKey Double where

15641150 "-Infinity" -> pure (negate 1/0)

15651151 _ -> Scientific.toRealFloat <$> parseScientificText t

15661152

1153+instance FromJSON Number where

1154+ parseJSON (Number s) = pure $ scientificToNumber s

1155+ parseJSON Null = pure (D (0/0))

1156+ parseJSON v = typeMismatch "Number" v

1157+ {-# INLINE parseJSON #-}

1158+

15671159instance FromJSON Float where

15681160 parseJSON = parseRealFloat "Float"

15691161 {-# INLINE parseJSON #-}

@@ -1576,30 +1168,17 @@ instance FromJSONKey Float where

15761168 _ -> Scientific.toRealFloat <$> parseScientificText t

15771169

15781170instance (FromJSON a, Integral a) => FromJSON (Ratio a) where

1579− parseJSON (Number x)

1580− | exp10 <= 1024

1581− , exp10 >= -1024 = return $! realToFrac x

1582− | otherwise = prependContext "Ratio" $ fail msg

1583− where

1584− exp10 = base10Exponent x

1585− msg = "found a number with exponent " ++ show exp10

1586− ++ ", but it must not be greater than 1024 or less than -1024"

1587− parseJSON o = objParser o

1588− where

1589− objParser = withObject "Rational" $ \obj -> do

1590− numerator <- obj .: "numerator"

1591− denominator <- obj .: "denominator"

1592− if denominator == 0

1593− then fail "Ratio denominator was 0"

1594− else pure $ numerator % denominator

1595− {-# INLINE parseJSON #-}

1596−

1597−-- | This instance includes a bounds check to prevent maliciously

1598−-- large inputs to fill up the memory of the target system. You can

1599−-- newtype 'Scientific' and provide your own instance using

1600−-- 'withScientific' if you want to allow larger inputs.

1171+ parseJSON = withObject "Rational" $ \obj ->

1172+ (%) <$> obj .: "numerator"

1173+ <*> obj .: "denominator"

1174+ {-# INLINE parseJSON #-}

1175+

1176+-- | /WARNING:/ Only parse fixed-precision numbers from trusted input

1177+-- since an attacker could easily fill up the memory of the target

1178+-- system by specifying a scientific number with a big exponent like

1179+-- @1e1000000000@.

16011180instance HasResolution a => FromJSON (Fixed a) where

1602− parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)

1181+ parseJSON = withScientific "Fixed" $ pure . realToFrac

16031182 {-# INLINE parseJSON #-}

16041183

16051184instance FromJSON Int where

@@ -1609,10 +1188,10 @@ instance FromJSON Int where

16091188instance FromJSONKey Int where

16101189 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"

16111190

1612−-- | This instance includes a bounds check to prevent maliciously

1613−-- large inputs to fill up the memory of the target system. You can

1614−-- newtype 'Scientific' and provide your own instance using

1615−-- 'withScientific' if you want to allow larger inputs.

1191+-- | /WARNING:/ Only parse Integers from trusted input since an

1192+-- attacker could easily fill up the memory of the target system by

1193+-- specifying a scientific number with a big exponent like

1194+-- @1e1000000000@.

16161195instance FromJSON Integer where

16171196 parseJSON = parseIntegral "Integer"

16181197 {-# INLINE parseJSON #-}

@@ -1621,21 +1200,16 @@ instance FromJSONKey Integer where

16211200 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"

16221201

16231202instance FromJSON Natural where

1624− parseJSON value = do

1625− integer <- parseIntegral "Natural" value

1626− parseNatural integer

1203+ parseJSON = withScientific "Natural" $ \s ->

1204+ if Scientific.coefficient s < 0

1205+ then fail $ "Expected a Natural number but got the negative number: " <> show s

1206+ else pure $ truncate s

16271207

16281208instance FromJSONKey Natural where

1629− fromJSONKey = FromJSONKeyTextParser $ \text -> do

1630− integer <- parseIntegralText "Natural" text

1631− parseNatural integer

1632−

1633−parseNatural :: Integer -> Parser Natural

1634−parseNatural integer =

1635− if integer < 0 then

1636− fail $ "parsing Natural failed, unexpected negative number " <> show integer

1637− else

1638− pure $ fromIntegral integer

1209+ fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->

1210+ if Scientific.coefficient s < 0

1211+ then fail $ "Expected a Natural number but got the negative number: " <> show s

1212+ else pure $ truncate s

16391213

16401214instance FromJSON Int8 where

16411215 parseJSON = parseBoundedIntegral "Int8"

@@ -1700,9 +1274,6 @@ instance FromJSON Word64 where

17001274instance FromJSONKey Word64 where

17011275 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"

17021276

1703−instance FromJSON CTime where

1704− parseJSON = fmap CTime . parseJSON

1705− {-# INLINE parseJSON #-}

17061277

17071278instance FromJSON Text where

17081279 parseJSON = withText "Text" pure

@@ -1732,17 +1303,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack

17321303 where

17331304 go [(v,[])] = return v

17341305 go (_ : xs) = go xs

1735− go _ = fail "parsing Version failed"

1306+ go _ = fail "could not parse Version"

17361307

17371308-------------------------------------------------------------------------------

17381309-- semigroups NonEmpty

17391310-------------------------------------------------------------------------------

17401311

17411312instance FromJSON1 NonEmpty where

1742− liftParseJSON p _ = withArray "NonEmpty" $

1313+ liftParseJSON p _ = withArray "NonEmpty a" $

17431314 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

17441315 where

1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"

1316+ ne [] = fail "Expected a NonEmpty but got an empty list"

17461317 ne (x:xs) = pure (x :| xs)

17471318 {-# INLINE liftParseJSON #-}

17481319

@@ -1763,7 +1334,7 @@ instance FromJSON Scientific where

17631334-------------------------------------------------------------------------------

17641335

17651336instance FromJSON1 DList.DList where

1766− liftParseJSON p _ = withArray "DList" $

1337+ liftParseJSON p _ = withArray "DList a" $

17671338 fmap DList.fromList .

17681339 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

17691340 {-# INLINE liftParseJSON #-}

@@ -1840,7 +1411,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where

18401411 inr = "InR"

18411412

18421413 liftParseJSON _ _ _ = fail $

1843− "parsing Sum failed, expected an object with a single property " ++

1414+ "expected an object with a single property " ++

18441415 "where the property key should be either " ++

18451416 "\"InL\" or \"InR\""

18461417 {-# INLINE liftParseJSON #-}

@@ -1854,7 +1425,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where

18541425-------------------------------------------------------------------------------

18551426

18561427instance FromJSON1 Seq.Seq where

1857− liftParseJSON p _ = withArray "Seq" $

1428+ liftParseJSON p _ = withArray "Seq a" $

18581429 fmap Seq.fromList .

18591430 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

18601431 {-# INLINE liftParseJSON #-}

@@ -1888,15 +1459,15 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where

18881459

18891460instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where

18901461 liftParseJSON p _ = case fromJSONKey of

1891− FromJSONKeyCoerce _ -> withObject "Map" $

1462+ FromJSONKeyCoerce _-> withObject "Map k v" $

18921463 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

1893− FromJSONKeyText f -> withObject "Map" $

1464+ FromJSONKeyText f -> withObject "Map k v" $

18941465 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

1895− FromJSONKeyTextParser f -> withObject "Map" $

1466+ FromJSONKeyTextParser f -> withObject "Map k v" $

18961467 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)

1897− FromJSONKeyValue f -> withArray "Map" $ \arr ->

1898− fmap M.fromList . Tr.sequence .

1899− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr

1468+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

1469+ M.fromList <$> (Tr.sequence .

1470+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

19001471 {-# INLINE liftParseJSON #-}

19011472

19021473instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where

@@ -1922,18 +1493,18 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where

19221493

19231494instance FromJSON UUID.UUID where

19241495 parseJSON = withText "UUID" $

1925− maybe (fail "invalid UUID") pure . UUID.fromText

1496+ maybe (fail "Invalid UUID") pure . UUID.fromText

19261497

19271498instance FromJSONKey UUID.UUID where

19281499 fromJSONKey = FromJSONKeyTextParser $

1929− maybe (fail "invalid UUID") pure . UUID.fromText

1500+ maybe (fail "Invalid UUID") pure . UUID.fromText

19301501

19311502-------------------------------------------------------------------------------

19321503-- vector

19331504-------------------------------------------------------------------------------

19341505

19351506instance FromJSON1 Vector where

1936− liftParseJSON p _ = withArray "Vector" $

1507+ liftParseJSON p _ = withArray "Vector a" $

19371508 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed

19381509 {-# INLINE liftParseJSON #-}

19391510

@@ -1947,14 +1518,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe

19471518{-# INLINE vectorParseJSON #-}

19481519

19491520instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where

1950− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"

1521+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"

19511522

19521523instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where

1953− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"

1524+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"

19541525 {-# INLINE parseJSON #-}

19551526

19561527instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where

1957− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"

1528+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

19581529 {-# INLINE parseJSON #-}

19591530

19601531-------------------------------------------------------------------------------

@@ -1968,15 +1539,15 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where

19681539

19691540instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where

19701541 liftParseJSON p _ = case fromJSONKey of

1971− FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $

1542+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $

19721543 uc . H.traverseWithKey (\k v -> p v <?> Key k)

1973− FromJSONKeyText f -> withObject "HashMap" $

1544+ FromJSONKeyText f -> withObject "HashMap k v" $

19741545 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)

1975− FromJSONKeyTextParser f -> withObject "HashMap" $

1546+ FromJSONKeyTextParser f -> withObject "HashMap k v" $

19761547 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)

1977− FromJSONKeyValue f -> withArray "Map" $ \arr ->

1978− fmap H.fromList . Tr.sequence .

1979− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr

1548+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

1549+ H.fromList <$> (Tr.sequence .

1550+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

19801551 where

19811552 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)

19821553 uc = unsafeCoerce

@@ -1997,33 +1568,11 @@ instance FromJSON DotNetTime where

19971568 parseJSON = withText "DotNetTime" $ \t ->

19981569 let (s,m) = T.splitAt (T.length t - 5) t

19991570 t' = T.concat [s,".",m]

2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

1571+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

20011572 Just d -> pure (DotNetTime d)

20021573 _ -> fail "could not parse .NET time"

20031574 {-# INLINE parseJSON #-}

20041575

2005−-------------------------------------------------------------------------------

2006−-- primitive

2007−-------------------------------------------------------------------------------

2008−

2009−instance FromJSON a => FromJSON (PM.Array a) where

2010− -- note: we could do better than this if vector exposed the data

2011− -- constructor in Data.Vector.

2012− parseJSON = fmap Exts.fromList . parseJSON

2013−

2014−instance FromJSON a => FromJSON (PM.SmallArray a) where

2015− parseJSON = fmap Exts.fromList . parseJSON

2016−

2017−#if MIN_VERSION_primitive(0,6,4)

2018−instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where

2019− parseJSON = fmap Exts.fromList . parseJSON

2020−

2021−#if !MIN_VERSION_primitive(0,7,0)

2022−instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where

2023− parseJSON = fmap Exts.fromList . parseJSON

2024−#endif

2025−#endif

2026−

20271576-------------------------------------------------------------------------------

20281577-- time

20291578-------------------------------------------------------------------------------

@@ -2049,17 +1598,6 @@ instance FromJSONKey LocalTime where

20491598 fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)

20501599

20511600

2052−-- | Supported string formats:

2053−--

2054−-- @YYYY-MM-DD HH:MM Z@

2055−-- @YYYY-MM-DD HH:MM:SS Z@

2056−-- @YYYY-MM-DD HH:MM:SS.SSS Z@

2057−--

2058−-- The first space may instead be a @T@, and the second space is

2059−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a

2060−-- time zone offset of the form @+0000@ or @-08:00@, where the first

2061−-- two digits are hours, the @:@ is optional and the second two digits

2062−-- (also optional) are minutes.

20631601instance FromJSON ZonedTime where

20641602 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)

20651603

@@ -2074,57 +1612,14 @@ instance FromJSONKey UTCTime where

20741612 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)

20751613

20761614

2077−-- | This instance includes a bounds check to prevent maliciously

2078−-- large inputs to fill up the memory of the target system. You can

2079−-- newtype 'Scientific' and provide your own instance using

2080−-- 'withScientific' if you want to allow larger inputs.

1615+-- | /WARNING:/ Only parse lengths of time from trusted input

1616+-- since an attacker could easily fill up the memory of the target

1617+-- system by specifying a scientific number with a big exponent like

1618+-- @1e1000000000@.

20811619instance FromJSON NominalDiffTime where

2082− parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac

2083− {-# INLINE parseJSON #-}

2084−

2085−

2086−-- | This instance includes a bounds check to prevent maliciously

2087−-- large inputs to fill up the memory of the target system. You can

2088−-- newtype 'Scientific' and provide your own instance using

2089−-- 'withScientific' if you want to allow larger inputs.

2090−instance FromJSON DiffTime where

2091− parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac

1620+ parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac

20921621 {-# INLINE parseJSON #-}

20931622

2094−instance FromJSON SystemTime where

2095− parseJSON v = prependContext "SystemTime" $ do

2096− n <- parseJSON v

2097− let n' = floor (n * fromInteger (resolution n) :: Nano)

2098− let (secs, nano) = n' `divMod` resolution n

2099− return (MkSystemTime (fromInteger secs) (fromInteger nano))

2100−

2101−instance FromJSON CalendarDiffTime where

2102− parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime

2103− <$> obj .: "months"

2104− <*> obj .: "time"

2105−

2106−instance FromJSON CalendarDiffDays where

2107− parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays

2108− <$> obj .: "months"

2109− <*> obj .: "days"

2110−

2111−instance FromJSON DayOfWeek where

2112− parseJSON = withText "DaysOfWeek" parseDayOfWeek

2113−

2114−parseDayOfWeek :: T.Text -> Parser DayOfWeek

2115−parseDayOfWeek t = case T.toLower t of

2116− "monday" -> return Monday

2117− "tuesday" -> return Tuesday

2118− "wednesday" -> return Wednesday

2119− "thursday" -> return Thursday

2120− "friday" -> return Friday

2121− "saturday" -> return Saturday

2122− "sunday" -> return Sunday

2123− _ -> fail "Invalid week day"

2124−

2125−instance FromJSONKey DayOfWeek where

2126− fromJSONKey = FromJSONKeyTextParser parseDayOfWeek

2127−

21281623-------------------------------------------------------------------------------

21291624-- base Monoid/Semigroup

21301625-------------------------------------------------------------------------------

@@ -2245,15 +1740,14 @@ instance FromJSON a => FromJSON (Semigroup.Option a) where

22451740

22461741instance FromJSON1 Proxy where

22471742 {-# INLINE liftParseJSON #-}

2248− liftParseJSON _ _ = fromNull "Proxy" Proxy

1743+ liftParseJSON _ _ Null = pure Proxy

1744+ liftParseJSON _ _ v = typeMismatch "Proxy" v

22491745

22501746instance FromJSON (Proxy a) where

22511747 {-# INLINE parseJSON #-}

2252− parseJSON = fromNull "Proxy" Proxy

1748+ parseJSON Null = pure Proxy

1749+ parseJSON v = typeMismatch "Proxy" v

22531750

2254−fromNull :: String -> a -> Value -> Parser a

2255−fromNull _ a Null = pure a

2256−fromNull c _ v = prependContext c (typeMismatch "Null" v)

22571751

22581752instance FromJSON2 Tagged where

22591753 liftParseJSON2 _ _ p _ = fmap Tagged . p

@@ -2280,7 +1774,10 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)

22801774instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)

22811775

22821776instance FromJSONKey Char where

2283− fromJSONKey = FromJSONKeyTextParser parseChar

1777+ fromJSONKey = FromJSONKeyTextParser $ \t ->

1778+ if T.length t == 1

1779+ then return (T.index t 0)

1780+ else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)

22841781 fromJSONKeyList = FromJSONKeyText T.unpack

22851782

22861783instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where

Data/Aeson/Types/Generic.hs+8−12

@@ -1,11 +1,10 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

43{-# LANGUAGE EmptyDataDecls #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE FunctionalDependencies #-}

76{-# LANGUAGE KindSignatures #-}

8−{-# LANGUAGE NoImplicitPrelude #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE ScopedTypeVariables #-}

109{-# LANGUAGE TypeOperators #-}

1110{-# LANGUAGE UndecidableInstances #-}

@@ -26,7 +25,7 @@

2625

2726module Data.Aeson.Types.Generic

2827 (

29− IsRecord

28+ IsRecord(..)

3029 , AllNullary

3130 , Tagged2(..)

3231 , True

@@ -35,9 +34,9 @@ module Data.Aeson.Types.Generic

3534 , Zero

3635 , One

3736 , ProductSize(..)

38− , (:*)(..)

3937 ) where

4038

39+import Prelude ()

4140import Prelude.Compat

4241

4342import GHC.Generics

@@ -45,8 +44,12 @@ import GHC.Generics

4544--------------------------------------------------------------------------------

4645

4746class IsRecord (f :: * -> *) isRecord | f -> isRecord

47+ where

48+ isUnary :: f a -> Bool

49+ isUnary = const True

4850

4951instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord

52+ where isUnary = const False

5053#if MIN_VERSION_base(4,9,0)

5154instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False

5255#else

@@ -58,6 +61,7 @@ instance IsRecord Par1 True

5861instance IsRecord (Rec1 f) True

5962instance IsRecord (f :.: g) True

6063instance IsRecord U1 False

64+ where isUnary = const False

6165

6266--------------------------------------------------------------------------------

6367

@@ -76,7 +80,6 @@ instance AllNullary (Rec1 f) False

7680instance AllNullary U1 True

7781

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

79− deriving Functor

8083

8184--------------------------------------------------------------------------------

8285

@@ -109,10 +112,3 @@ instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where

109112

110113instance ProductSize (S1 s a) where

111114 productSize = Tagged2 1

112−

113−--------------------------------------------------------------------------------

114−

115−-- | Simple extensible tuple type to simplify passing around many parameters.

116−data a :* b = a :* b

117−

118−infixr 1 :*

Data/Aeson/Types/Internal.hs+26−175

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

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

43{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE NoImplicitPrelude #-}

64{-# LANGUAGE Rank2Types #-}

5+{-# LANGUAGE RecordWildCards #-}

76#if __GLASGOW_HASKELL__ >= 800

87-- a) THQ works on cross-compilers and unregisterised GHCs

98-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)

@@ -45,33 +44,16 @@ module Data.Aeson.Types.Internal

4544 , parseEither

4645 , parseMaybe

4746 , modifyFailure

48− , prependFailure

49− , parserThrowError

50− , parserCatchError

5147 , formatError

52− , formatPath

53− , formatRelativePath

5448 , (<?>)

5549 -- * Constructors and accessors

5650 , object

5751

5852 -- * Generic and TH encoding configuration

59− , Options(

60− fieldLabelModifier

61− , constructorTagModifier

62− , allNullaryToStringTag

63− , omitNothingFields

64− , sumEncoding

65− , unwrapUnaryRecords

66− , tagSingleConstructors

67− , rejectUnknownFields

68− )

69−

53+ , Options(..)

7054 , SumEncoding(..)

71− , JSONKeyOptions(keyModifier)

7255 , defaultOptions

7356 , defaultTaggedObject

74− , defaultJSONKeyOptions

7557

7658 -- * Used for changing CamelCase names into something else.

7759 , camelTo

@@ -81,6 +63,7 @@ module Data.Aeson.Types.Internal

8163 , DotNetTime(..)

8264 ) where

8365

66+import Prelude ()

8467import Prelude.Compat

8568

8669import Control.Applicative (Alternative(..))

@@ -92,7 +75,6 @@ import Data.Data (Data)

9275import Data.Foldable (foldl')

9376import Data.HashMap.Strict (HashMap)

9477import Data.Hashable (Hashable(..))

95−import Data.List (intercalate)

9678import Data.Scientific (Scientific)

9779import Data.Semigroup (Semigroup((<>)))

9880import Data.String (IsString(..))

@@ -101,8 +83,6 @@ import Data.Time (UTCTime)

10183import Data.Time.Format (FormatTime)

10284import Data.Typeable (Typeable)

10385import Data.Vector (Vector)

104−import GHC.Generics (Generic)

105−import qualified Control.Monad as Monad

10686import qualified Control.Monad.Fail as Fail

10787import qualified Data.HashMap.Strict as H

10888import qualified Data.Scientific as S

@@ -121,7 +101,7 @@ data JSONPathElement = Key Text

121101 | Index {-# UNPACK #-} !Int

122102 -- ^ JSON path element of an index into an

123103 -- array, \"array[index]\".

124− deriving (Eq, Show, Typeable, Ord)

104+ deriving (Eq, Show, Typeable)

125105type JSONPath = [JSONPathElement]

126106

127107-- | The internal result of running a 'Parser'.

@@ -156,7 +136,7 @@ instance Functor Result where

156136 fmap _ (Error err) = Error err

157137 {-# INLINE fmap #-}

158138

159−instance Monad.Monad IResult where

139+instance Monad IResult where

160140 return = pure

161141 {-# INLINE return #-}

162142

@@ -164,16 +144,14 @@ instance Monad.Monad IResult where

164144 IError path err >>= _ = IError path err

165145 {-# INLINE (>>=) #-}

166146

167−#if !(MIN_VERSION_base(4,13,0))

168147 fail = Fail.fail

169148 {-# INLINE fail #-}

170−#endif

171149

172150instance Fail.MonadFail IResult where

173151 fail err = IError [] err

174152 {-# INLINE fail #-}

175153

176−instance Monad.Monad Result where

154+instance Monad Result where

177155 return = pure

178156 {-# INLINE return #-}

179157

@@ -181,10 +159,8 @@ instance Monad.Monad Result where

181159 Error err >>= _ = Error err

182160 {-# INLINE (>>=) #-}

183161

184−#if !(MIN_VERSION_base(4,13,0))

185162 fail = Fail.fail

186163 {-# INLINE fail #-}

187−#endif

188164

189165instance Fail.MonadFail Result where

190166 fail err = Error err

@@ -281,9 +257,7 @@ type Failure f r = JSONPath -> String -> f r

281257-- | Success continuation.

282258type Success a f r = a -> f r

283259

284−-- | A JSON parser. N.B. This might not fit your usual understanding of

285−-- "parser". Instead you might like to think of 'Parser' as a "parse result",

286−-- i.e. a parser to which the input has already been applied.

260+-- | A JSON parser.

287261newtype Parser a = Parser {

288262 runParser :: forall f r.

289263 JSONPath

@@ -292,17 +266,14 @@ newtype Parser a = Parser {

292266 -> f r

293267 }

294268

295−instance Monad.Monad Parser where

269+instance Monad Parser where

296270 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks

297271 in runParser m path kf ks'

298272 {-# INLINE (>>=) #-}

299273 return = pure

300274 {-# INLINE return #-}

301−

302−#if !(MIN_VERSION_base(4,13,0))

303275 fail = Fail.fail

304276 {-# INLINE fail #-}

305−#endif

306277

307278instance Fail.MonadFail Parser where

308279 fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

@@ -345,7 +316,8 @@ instance Monoid (Parser a) where

345316apP :: Parser (a -> b) -> Parser a -> Parser b

346317apP d e = do

347318 b <- d

348− b <$> e

319+ a <- e

320+ return (b a)

349321{-# INLINE apP #-}

350322

351323-- | A JSON \"object\" (key\/value map).

@@ -361,7 +333,7 @@ data Value = Object !Object

361333 | Number !Scientific

362334 | Bool !Bool

363335 | Null

364− deriving (Eq, Read, Show, Typeable, Data, Generic)

336+ deriving (Eq, Read, Show, Typeable, Data)

365337

366338-- | A newtype wrapper for 'UTCTime' that uses the same non-standard

367339-- serialization format as Microsoft .NET, whose

@@ -461,17 +433,7 @@ parseEither m v = runParser (m v) [] onError Right

461433-- | Annotate an error message with a

462434-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

463435formatError :: JSONPath -> String -> String

464−formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg

465−

466−-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String',

467−-- representing the root object as @$@.

468−formatPath :: JSONPath -> String

469−formatPath path = "$" ++ formatRelativePath path

470−

471−-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String'

472−-- which represents the path relative to some root object.

473−formatRelativePath :: JSONPath -> String

474−formatRelativePath path = format "" path

436+formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg

475437 where

476438 format :: String -> JSONPath -> String

477439 format pfx [] = pfx

@@ -534,40 +496,13 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks

534496--

535497-- Since 0.6.2.0

536498modifyFailure :: (String -> String) -> Parser a -> Parser a

537−modifyFailure f (Parser p) = Parser $ \path kf ks ->

538− p path (\p' m -> kf p' (f m)) ks

539−

540−-- | If the inner 'Parser' failed, prepend the given string to the failure

541−-- message.

542−--

543−-- @

544−-- 'prependFailure' s = 'modifyFailure' (s '++')

545−-- @

546−prependFailure :: String -> Parser a -> Parser a

547−prependFailure = modifyFailure . (++)

548−

549−-- | Throw a parser error with an additional path.

550−--

551−-- @since 1.2.1.0

552−parserThrowError :: JSONPath -> String -> Parser a

553−parserThrowError path' msg = Parser $ \path kf _ks ->

554− kf (reverse path ++ path') msg

555−

556−-- | A handler function to handle previous errors and return to normal execution.

557−--

558−-- @since 1.2.1.0

559−parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a

560−parserCatchError (Parser p) handler = Parser $ \path kf ks ->

561− p path (\e msg -> runParser (handler e msg) path kf ks) ks

499+modifyFailure f (Parser p) = Parser $ \path kf ks -> p path (\p' m -> kf p' (f m)) ks

562500

563501--------------------------------------------------------------------------------

564502-- Generic and TH encoding configuration

565503--------------------------------------------------------------------------------

566504

567505-- | Options that specify how to encode\/decode your datatype to\/from JSON.

568−--

569−-- Options can be set using record syntax on 'defaultOptions' with the fields

570−-- below.

571506data Options = Options

572507 { fieldLabelModifier :: String -> String

573508 -- ^ Function applied to field labels.

@@ -584,67 +519,24 @@ data Options = Options

584519 -- ^ If 'True' record fields with a 'Nothing' value will be

585520 -- omitted from the resulting object. If 'False' the resulting

586521 -- object will include those fields mapping to @null@.

587− --

588− -- === Note

589− --

590− -- Setting 'omitNothingFields' to 'True' only affects fields which are of

591− -- type 'Maybe' /uniformly/ in the 'ToJSON' or 'FromJSON' instance. In

592− -- particular, if the type of a field is declared as a type variable, it

593− -- will not be omitted from the JSON object, unless the field is

594− -- specialized upfront in the instance.

595− --

596− -- ==== __Example__

597− --

598− -- The generic instance for the following type @Fruit@ depends on whether

599− -- the instance head is @Fruit a@ or @Fruit (Maybe a)@.

600− --

601− -- @

602− -- data Fruit a =

603− -- { apples :: a -- A field whose type is a type variable.

604− -- , oranges :: 'Maybe' Int

605− -- }

606− --

607− -- options :: 'Options'

608− -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }

609− --

610− -- -- apples required, oranges optional

611− -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).

612− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) where

613− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

614− --

615− -- -- apples optional, oranges optional

616− -- -- In this instance, the field apples is uniformly of type ('Maybe' a).

617− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) where

618− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

619− -- @

620522 , sumEncoding :: SumEncoding

621523 -- ^ Specifies how to encode constructors of a sum datatype.

622524 , unwrapUnaryRecords :: Bool

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

624526 -- field, like a newtype.

625− , tagSingleConstructors :: Bool

626− -- ^ Encode types with a single constructor as sums,

627− -- so that `allNullaryToStringTag` and `sumEncoding` apply.

628− , rejectUnknownFields :: Bool

629− -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in

630− -- the parsed object map, but does not appear in the target object, parsing

631− -- will fail, with an error message indicating which fields were unknown.

632527 }

633528

634529instance Show Options where

635− show (Options f c a o s u t r) =

636− "Options {"

637− ++ intercalate ", "

638− [ "fieldLabelModifier =~ " ++ show (f "exampleField")

639− , "constructorTagModifier =~ " ++ show (c "ExampleConstructor")

640− , "allNullaryToStringTag = " ++ show a

641− , "omitNothingFields = " ++ show o

642− , "sumEncoding = " ++ show s

643− , "unwrapUnaryRecords = " ++ show u

644− , "tagSingleConstructors = " ++ show t

645− , "rejectUnknownFields = " ++ show r

646− ]

647− ++ "}"

530+ show Options{..} = "Options {" ++

531+ "fieldLabelModifier =~ " ++

532+ show (fieldLabelModifier "exampleField") ++ ", " ++

533+ "constructorTagModifier =~ " ++

534+ show (constructorTagModifier "ExampleConstructor") ++ ", " ++

535+ "allNullaryToStringTag = " ++ show allNullaryToStringTag ++ ", " ++

536+ "omitNothingFields = " ++ show omitNothingFields ++ ", " ++

537+ "sumEncoding = " ++ show sumEncoding ++ ", " ++

538+ "unwrapUnaryRecords = " ++ show unwrapUnaryRecords ++

539+ "}"

648540

649541-- | Specifies how to encode constructors of a sum datatype.

650542data SumEncoding =

@@ -662,18 +554,18 @@ data SumEncoding =

662554 -- the 'contentsFieldName' field.

663555 | UntaggedValue

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

665− -- constructor will be encoded as if the type had a single constructor. JSON

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

666558 -- encodings have to be disjoint for decoding to work properly.

667559 --

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

669561 -- encodings overlap, the first one defined will succeed.

670562 --

671− -- /Note:/ Nullary constructors are encoded as strings (using

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

672564 -- 'constructorTagModifier'). Having a nullary constructor alongside a

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

674566 --

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

676− -- malformed JSON, only an error for the last constructor will be reported.

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

677569 | ObjectWithSingleField

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

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

@@ -686,33 +578,6 @@ data SumEncoding =

686578 -- contents of the constructor.

687579 deriving (Eq, Show)

688580

689−-- | Options for encoding keys with 'Data.Aeson.Types.genericFromJSONKey' and

690−-- 'Data.Aeson.Types.genericToJSONKey'.

691−data JSONKeyOptions = JSONKeyOptions

692− { keyModifier :: String -> String

693− -- ^ Function applied to keys. Its result is what goes into the encoded

694− -- 'Value'.

695− --

696− -- === __Example__

697− --

698− -- The following instances encode the constructor @Bar@ to lower-case keys

699− -- @\"bar\"@.

700− --

701− -- @

702− -- data Foo = Bar

703− -- deriving 'Generic'

704− --

705− -- opts :: 'JSONKeyOptions'

706− -- opts = 'defaultJSONKeyOptions' { 'keyModifier' = 'toLower' }

707− --

708− -- instance 'ToJSONKey' Foo where

709− -- 'toJSONKey' = 'genericToJSONKey' opts

710− --

711− -- instance 'FromJSONKey' Foo where

712− -- 'fromJSONKey' = 'genericFromJSONKey' opts

713− -- @

714− }

715−

716581-- | Default encoding 'Options':

717582--

718583-- @

@@ -723,8 +588,6 @@ data JSONKeyOptions = JSONKeyOptions

723588-- , 'omitNothingFields' = False

724589-- , 'sumEncoding' = 'defaultTaggedObject'

725590-- , 'unwrapUnaryRecords' = False

726−-- , 'tagSingleConstructors' = False

727−-- , 'rejectUnknownFields' = False

728591-- }

729592-- @

730593defaultOptions :: Options

@@ -735,8 +598,6 @@ defaultOptions = Options

735598 , omitNothingFields = False

736599 , sumEncoding = defaultTaggedObject

737600 , unwrapUnaryRecords = False

738− , tagSingleConstructors = False

739− , rejectUnknownFields = False

740601 }

741602

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

@@ -753,16 +614,6 @@ defaultTaggedObject = TaggedObject

753614 , contentsFieldName = "contents"

754615 }

755616

756−-- | Default 'JSONKeyOptions':

757−--

758−-- @

759−-- defaultJSONKeyOptions = 'JSONKeyOptions'

760−-- { 'keyModifier' = 'id'

761−-- }

762−-- @

763−defaultJSONKeyOptions :: JSONKeyOptions

764−defaultJSONKeyOptions = JSONKeyOptions id

765−

766617-- | Converts from CamelCase to another lower case, interspersing

767618-- the character between all capital letters and their previous

768619-- entries, except those capital letters that appear together,

Data/Aeson/Types/ToJSON.hs+532−587

@@ -1,21 +1,25 @@

1+{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

24{-# LANGUAGE DefaultSignatures #-}

3−{-# LANGUAGE EmptyDataDecls #-}

45{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

77{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE NoImplicitPrelude #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE NamedFieldPuns #-}

910{-# LANGUAGE OverloadedStrings #-}

1011{-# LANGUAGE PatternGuards #-}

11−{-# LANGUAGE PolyKinds #-}

1212{-# LANGUAGE RecordWildCards #-}

1313{-# LANGUAGE ScopedTypeVariables #-}

1414{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE TypeSynonymInstances #-}

1516{-# LANGUAGE UndecidableInstances #-}

1617

18+#if __GLASGOW_HASKELL__ >= 706

19+{-# LANGUAGE PolyKinds #-}

20+#endif

21+

1722#include "overlapping-compat.h"

18−#include "incoherent-compat.h"

1923

2024-- TODO: Drop this when we remove support for Data.Attoparsec.Number

2125{-# OPTIONS_GHC -fno-warn-deprecations #-}

@@ -33,6 +37,7 @@ module Data.Aeson.Types.ToJSON

3337 , toEncoding2

3438 -- * Generic JSON classes

3539 , GToJSON(..)

40+ , GToEncoding(..)

3641 , ToArgs(..)

3742 , genericToJSON

3843 , genericToEncoding

@@ -43,63 +48,54 @@ module Data.Aeson.Types.ToJSON

4348 , ToJSONKeyFunction(..)

4449 , toJSONKeyText

4550 , contramapToJSONKeyFunction

46−

47− , GToJSONKey()

48− , genericToJSONKey

49−

5051 -- * Object key-value pairs

5152 , KeyValue(..)

52− , KeyValuePair(..)

53− , FromPairs(..)

5453 -- * Functions needed for documentation

5554 -- * Encoding functions

5655 , listEncoding

5756 , listValue

5857 ) where

5958

59+import Prelude ()

6060import Prelude.Compat

6161

6262import Control.Applicative (Const(..))

6363import Control.Monad.ST (ST)

6464import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)

65−import Data.Aeson.Encoding.Internal ((>*<))

65+import Data.Aeson.Encoding.Internal ((>*<), (><))

6666import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)

67−import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize)

67+import Data.Aeson.Types.Generic (AllNullary, False, IsRecord(..), One, ProductSize, Tagged2(..), True, Zero, productSize)

6868import Data.Aeson.Types.Internal

6969import Data.Attoparsec.Number (Number(..))

7070import Data.Bits (unsafeShiftR)

7171import Data.DList (DList)

72−import Data.Fixed (Fixed, HasResolution, Nano)

72+import Data.Fixed (Fixed, HasResolution)

7373import Data.Foldable (toList)

7474import Data.Functor.Compose (Compose(..))

75−import Data.Functor.Contravariant (Contravariant (..))

7675import Data.Functor.Identity (Identity(..))

7776import Data.Functor.Product (Product(..))

7877import Data.Functor.Sum (Sum(..))

7978import Data.Int (Int16, Int32, Int64, Int8)

8079import Data.List (intersperse)

8180import Data.List.NonEmpty (NonEmpty(..))

82−import Data.Semigroup ((<>))

81+import Data.Monoid ((<>))

8382import Data.Proxy (Proxy(..))

8483import Data.Ratio (Ratio, denominator, numerator)

8584import Data.Scientific (Scientific)

8685import Data.Tagged (Tagged(..))

8786import Data.Text (Text, pack)

88−import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

89−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

90−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

91−import Data.Time.Clock.System.Compat (SystemTime (..))

92−import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)

87+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

88+import Data.Time.Format (FormatTime, formatTime)

89+import Data.Time.Locale.Compat (defaultTimeLocale)

9390import Data.Vector (Vector)

9491import Data.Version (Version, showVersion)

95−import Data.Void (Void, absurd)

9692import Data.Word (Word16, Word32, Word64, Word8)

9793import Foreign.Storable (Storable)

98−import Foreign.C.Types (CTime (..))

9994import GHC.Generics

10095import Numeric.Natural (Natural)

10196import qualified Data.Aeson.Encoding as E

102−import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)

97+import qualified Data.Aeson.Encoding.Internal as E (InArray, colon, comma, econcat, empty, retagEncoding, wrapObject)

98+import qualified Data.ByteString as S

10399import qualified Data.ByteString.Lazy as L

104100import qualified Data.DList as DList

105101import qualified Data.HashMap.Strict as H

@@ -128,16 +124,12 @@ import qualified Data.Vector.Unboxed as VU

128124import qualified Data.Aeson.Encoding.Builder as EB

129125import qualified Data.ByteString.Builder as B

130126

131−import qualified GHC.Exts as Exts

132−import qualified Data.Primitive.Array as PM

133−import qualified Data.Primitive.SmallArray as PM

134−import qualified Data.Primitive.Types as PM

135−

136−#if MIN_VERSION_primitive(0,6,4)

137−#if !MIN_VERSION_primitive(0,7,0)

138−import qualified Data.Primitive.UnliftedArray as PM

139−#endif

140−import qualified Data.Primitive.PrimArray as PM

127+#if !(MIN_VERSION_bytestring(0,10,0))

128+import Foreign.ForeignPtr (withForeignPtr)

129+import Foreign.Marshal.Utils (copyBytes)

130+import Foreign.Ptr (plusPtr)

131+import qualified Data.ByteString.Internal as S

132+import qualified Data.ByteString.Lazy.Internal as L

141133#endif

142134

143135toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

@@ -156,16 +148,19 @@ realFloatToJSON d

156148

157149-- | Class of generic representation types that can be converted to

158150-- JSON.

159−class GToJSON enc arity f where

151+class GToJSON arity f where

160152 -- | This method (applied to 'defaultOptions') is used as the

161− -- default generic implementation of 'toJSON'

162− -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)

163− -- and 'liftToJSON' (if the @arity@ is 'One').

164− --

165− -- It also provides a generic implementation of 'toEncoding'

166− -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)

167− -- and 'liftToEncoding' (if the @arity@ is 'One').

168− gToJSON :: Options -> ToArgs enc arity a -> f a -> enc

153+ -- default generic implementation of 'toJSON' (if the @arity@ is 'Zero')

154+ -- or 'liftToJSON' (if the @arity@ is 'One').

155+ gToJSON :: Options -> ToArgs Value arity a -> f a -> Value

156+

157+-- | Class of generic representation types that can be converted to

158+-- a JSON 'Encoding'.

159+class GToEncoding arity f where

160+ -- | This method (applied to 'defaultOptions') can be used as the

161+ -- default generic implementation of 'toEncoding' (if the @arity@ is 'Zero')

162+ -- or 'liftToEncoding' (if the @arity@ is 'One').

163+ gToEncoding :: Options -> ToArgs Encoding arity a -> f a -> Encoding

169164

170165-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two

171166-- function arguments that encode occurrences of the type parameter (for

@@ -177,14 +172,14 @@ data ToArgs res arity a where

177172-- | A configurable generic JSON creator. This function applied to

178173-- 'defaultOptions' is used as the default for 'toJSON' when the type

179174-- is an instance of 'Generic'.

180−genericToJSON :: (Generic a, GToJSON Value Zero (Rep a))

175+genericToJSON :: (Generic a, GToJSON Zero (Rep a))

181176 => Options -> a -> Value

182177genericToJSON opts = gToJSON opts NoToArgs . from

183178

184179-- | A configurable generic JSON creator. This function applied to

185180-- 'defaultOptions' is used as the default for 'liftToJSON' when the type

186181-- is an instance of 'Generic1'.

187−genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))

182+genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f))

188183 => Options -> (a -> Value) -> ([a] -> Value)

189184 -> f a -> Value

190185genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1

@@ -192,17 +187,17 @@ genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1

192187-- | A configurable generic JSON encoder. This function applied to

193188-- 'defaultOptions' is used as the default for 'toEncoding' when the type

194189-- is an instance of 'Generic'.

195−genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a))

190+genericToEncoding :: (Generic a, GToEncoding Zero (Rep a))

196191 => Options -> a -> Encoding

197−genericToEncoding opts = gToJSON opts NoToArgs . from

192+genericToEncoding opts = gToEncoding opts NoToArgs . from

198193

199194-- | A configurable generic JSON encoder. This function applied to

200195-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type

201196-- is an instance of 'Generic1'.

202−genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))

197+genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))

203198 => Options -> (a -> Encoding) -> ([a] -> Encoding)

204199 -> f a -> Encoding

205−genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

200+genericLiftToEncoding opts te tel = gToEncoding opts (To1Args te tel) . from1

206201

207202-------------------------------------------------------------------------------

208203-- Class

@@ -210,9 +205,6 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

210205

211206-- | A type that can be converted to JSON.

212207--

213−-- Instances in general /must/ specify 'toJSON' and /should/ (but don't need

214−-- to) specify 'toEncoding'.

215−--

216208-- An example type and instance:

217209--

218210-- @

@@ -221,10 +213,10 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

221213--

222214-- data Coord = Coord { x :: Double, y :: Double }

223215--

224−-- instance 'ToJSON' Coord where

225−-- 'toJSON' (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]

216+-- instance ToJSON Coord where

217+-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]

226218--

227−-- 'toEncoding' (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)

219+-- toEncoding (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)

228220-- @

229221--

230222-- Instead of manually writing your 'ToJSON' instance, there are two options

@@ -232,15 +224,17 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

232224--

233225-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

234226-- instance at compile time. The generated instance is optimized for your type

235−-- so it will probably be more efficient than the following option.

227+-- so will probably be more efficient than the following two options:

236228--

237229-- * The compiler can provide a default generic implementation for

238230-- 'toJSON'.

239231--

240232-- To use the second, simply add a @deriving 'Generic'@ clause to your

241−-- datatype and declare a 'ToJSON' instance. If you require nothing other than

242−-- 'defaultOptions', it is sufficient to write (and this is the only

243−-- alternative where the default 'toJSON' implementation is sufficient):

233+-- datatype and declare a 'ToJSON' instance for your datatype without giving

234+-- definitions for 'toJSON' or 'toEncoding'.

235+--

236+-- For example, the previous example can be simplified to a more

237+-- minimal instance:

244238--

245239-- @

246240-- {-\# LANGUAGE DeriveGeneric \#-}

@@ -249,46 +243,35 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

249243--

250244-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'

251245--

252−-- instance 'ToJSON' Coord where

253−-- 'toEncoding' = 'genericToEncoding' 'defaultOptions'

246+-- instance ToJSON Coord where

247+-- toEncoding = 'genericToEncoding' 'defaultOptions'

254248-- @

255249--

256−-- If on the other hand you wish to customize the generic decoding, you have

257−-- to implement both methods:

250+-- Why do we provide an implementation for 'toEncoding' here? The

251+-- 'toEncoding' function is a relatively new addition to this class.

252+-- To allow users of older versions of this library to upgrade without

253+-- having to edit all of their instances or encounter surprising

254+-- incompatibilities, the default implementation of 'toEncoding' uses

255+-- 'toJSON'. This produces correct results, but since it performs an

256+-- intermediate conversion to a 'Value', it will be less efficient

257+-- than directly emitting an 'Encoding'. Our one-liner definition of

258+-- 'toEncoding' above bypasses the intermediate 'Value'.

259+--

260+-- If @DefaultSignatures@ doesn't give exactly the results you want,

261+-- you can customize the generic encoding with only a tiny amount of

262+-- effort, using 'genericToJSON' and 'genericToEncoding' with your

263+-- preferred 'Options':

258264--

259265-- @

260−-- customOptions = 'defaultOptions'

261−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

262−-- }

263−--

264−-- instance 'ToJSON' Coord where

265−-- 'toJSON' = 'genericToJSON' customOptions

266−-- 'toEncoding' = 'genericToEncoding' customOptions

266+-- instance ToJSON Coord where

267+-- toJSON = 'genericToJSON' 'defaultOptions'

268+-- toEncoding = 'genericToEncoding' 'defaultOptions'

267269-- @

268−--

269−-- Previous versions of this library only had the 'toJSON' method. Adding

270−-- 'toEncoding' had two reasons:

271−--

272−-- 1. toEncoding is more efficient for the common case that the output of

273−-- 'toJSON' is directly serialized to a @ByteString@.

274−-- Further, expressing either method in terms of the other would be

275−-- non-optimal.

276−--

277−-- 2. The choice of defaults allows a smooth transition for existing users:

278−-- Existing instances that do not define 'toEncoding' still

279−-- compile and have the correct semantics. This is ensured by making

280−-- the default implementation of 'toEncoding' use 'toJSON'. This produces

281−-- correct results, but since it performs an intermediate conversion to a

282−-- 'Value', it will be less efficient than directly emitting an 'Encoding'.

283−-- (this also means that specifying nothing more than

284−-- @instance ToJSON Coord@ would be sufficient as a generically decoding

285−-- instance, but there probably exists no good reason to not specify

286−-- 'toEncoding' in new instances.)

287270class ToJSON a where

288271 -- | Convert a Haskell value to a JSON-friendly intermediate type.

289272 toJSON :: a -> Value

290273

291− default toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value

274+ default toJSON :: (Generic a, GToJSON Zero (Rep a)) => a -> Value

292275 toJSON = genericToJSON defaultOptions

293276

294277 -- | Encode a Haskell value as JSON.

@@ -305,8 +288,8 @@ class ToJSON a where

305288 -- extension, and then have GHC generate a method body as follows.

306289 --

307290 -- @

308− -- instance 'ToJSON' Coord where

309− -- 'toEncoding' = 'genericToEncoding' 'defaultOptions'

291+ -- instance ToJSON Coord where

292+ -- toEncoding = 'genericToEncoding' 'defaultOptions'

310293 -- @

311294

312295 toEncoding :: a -> Encoding

@@ -338,13 +321,6 @@ instance KeyValue Pair where

338321 name .= value = (name, toJSON value)

339322 {-# INLINE (.=) #-}

340323

341−-- | Constructs a singleton 'H.HashMap'. For calling functions that

342−-- demand an 'Object' for constructing objects. To be used in

343−-- conjunction with 'mconcat'. Prefer to use 'object' where possible.

344−instance KeyValue Object where

345− name .= value = H.singleton name (toJSON value)

346− {-# INLINE (.=) #-}

347−

348324-------------------------------------------------------------------------------

349325-- Classes and types for map keys

350326-------------------------------------------------------------------------------

@@ -402,7 +378,7 @@ instance KeyValue Object where

402378-- newtype wrapper around 'Text'. The recommended approach is to use

403379-- generalized newtype deriving:

404380--

405−-- > newtype RecordId = RecordId { getRecordId :: Text }

381+-- > newtype RecordId = RecordId { getRecordId :: Text}

406382-- > deriving (Eq,Ord,ToJSONKey)

407383--

408384-- Then we may write:

@@ -417,18 +393,8 @@ instance KeyValue Object where

417393--

418394-- It is possible to get the 'ToJSONKey' instance for free as we did

419395-- with 'Foo'. However, in this case, we have a natural way to go to

420−-- and from 'Text' that does not require any escape sequences. So

421−-- 'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps

422−-- as objects instead of arrays of pairs. This instance may be

423−-- implemented using generics as follows:

424−--

425−-- @

426−-- instance 'ToJSONKey' Color where

427−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

428−-- @

429−--

430−-- === __Low-level implementations__

431−--

396+-- and from 'Text' that does not require any escape sequences. So, in

397+-- this example, 'ToJSONKeyText' will be used instead of 'ToJSONKeyValue'.

432398-- The 'Show' instance can be used to help write 'ToJSONKey':

433399--

434400-- > instance ToJSONKey Color where

@@ -503,42 +469,16 @@ toJSONKeyTextEnc e = ToJSONKeyText tot e

503469 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm

504470 tot = T.dropAround (== '"')

505471 . T.decodeLatin1

506− . L.toStrict

472+ . lazyToStrictByteString

507473 . E.encodingToLazyByteString

508474 . e

509475

510−instance Contravariant ToJSONKeyFunction where

511− contramap = contramapToJSONKeyFunction

512−

513476-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.

514477contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b

515478contramapToJSONKeyFunction h x = case x of

516479 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

517480 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

518481

519−-- 'toJSONKey' for 'Generic' types.

520−-- Deriving is supported for enumeration types, i.e. the sums of nullary

521−-- constructors. The names of constructors will be used as keys for JSON

522−-- objects.

523−--

524−-- See also 'genericFromJSONKey'.

525−--

526−-- === __Example__

527−--

528−-- @

529−-- data Color = Red | Green | Blue

530−-- deriving 'Generic'

531−--

532−-- instance 'ToJSONKey' Color where

533−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

534−-- @

535−genericToJSONKey :: (Generic a, GToJSONKey (Rep a))

536− => JSONKeyOptions -> ToJSONKeyFunction a

537−genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)

538−

539−class GetConName f => GToJSONKey f

540−instance GetConName f => GToJSONKey f

541−

542482-------------------------------------------------------------------------------

543483-- Lifings of FromJSON and ToJSON to unary and binary type constructors

544484-------------------------------------------------------------------------------

@@ -551,7 +491,7 @@ instance GetConName f => GToJSONKey f

551491--

552492-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

553493-- instance at compile time. The generated instance is optimized for your type

554−-- so it will probably be more efficient than the following option.

494+-- so will probably be more efficient than the following two options:

555495--

556496-- * The compiler can provide a default generic implementation for

557497-- 'toJSON1'.

@@ -569,29 +509,23 @@ instance GetConName f => GToJSONKey f

569509--

570510-- data Pair = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'

571511--

572−-- instance 'ToJSON' a => 'ToJSON1' (Pair a)

512+-- instance ToJSON a => ToJSON1 (Pair a)

573513-- @

574514--

575−-- If the default implementation doesn't give exactly the results you want,

515+-- If @DefaultSignatures@ doesn't give exactly the results you want,

576516-- you can customize the generic encoding with only a tiny amount of

577517-- effort, using 'genericLiftToJSON' and 'genericLiftToEncoding' with

578518-- your preferred 'Options':

579519--

580520-- @

581−-- customOptions = 'defaultOptions'

582−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

583−-- }

584−--

585−-- instance 'ToJSON' a => 'ToJSON1' (Pair a) where

586−-- 'liftToJSON' = 'genericLiftToJSON' customOptions

587−-- 'liftToEncoding' = 'genericLiftToEncoding' customOptions

521+-- instance ToJSON a => ToJSON1 (Pair a) where

522+-- liftToJSON = 'genericLiftToJSON' 'defaultOptions'

523+-- liftToEncoding = 'genericLiftToEncoding' 'defaultOptions'

588524-- @

589−--

590−-- See also 'ToJSON'.

591525class ToJSON1 f where

592526 liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value

593527

594− default liftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))

528+ default liftToJSON :: (Generic1 f, GToJSON One (Rep1 f))

595529 => (a -> Value) -> ([a] -> Value) -> f a -> Value

596530 liftToJSON = genericLiftToJSON defaultOptions

597531

@@ -600,7 +534,7 @@ class ToJSON1 f where

600534

601535 liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding

602536

603− default liftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))

537+ default liftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))

604538 => (a -> Encoding) -> ([a] -> Encoding)

605539 -> f a -> Encoding

606540 liftToEncoding = genericLiftToEncoding defaultOptions

@@ -654,7 +588,7 @@ toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingLis

654588-- @

655589-- newtype F a = F [a]

656590--

657−-- -- This instance encodes 'String' as an array of chars

591+-- -- This instance encodes String as an array of chars

658592-- instance 'ToJSON1' F where

659593-- 'liftToJSON' tj _ (F xs) = 'liftToJSON' tj ('listValue' tj) xs

660594-- 'liftToEncoding' te _ (F xs) = 'liftToEncoding' te ('listEncoding' te) xs

@@ -700,80 +634,39 @@ instance (ToJSON a) => ToJSON [a] where

700634-- Generic toJSON / toEncoding

701635-------------------------------------------------------------------------------

702636

703−instance OVERLAPPABLE_ (GToJSON enc arity a) => GToJSON enc arity (M1 i c a) where

704− -- Meta-information, which is not handled elsewhere, is ignored:

705− gToJSON opts targs = gToJSON opts targs . unM1

706− {-# INLINE gToJSON #-}

707−

708−instance GToJSON enc One Par1 where

709− -- Direct occurrences of the last type parameter are encoded with the

710− -- function passed in as an argument:

711− gToJSON _opts (To1Args tj _) = tj . unPar1

712− {-# INLINE gToJSON #-}

713−

714−instance ( ConsToJSON enc arity a

715− , AllNullary (C1 c a) allNullary

716− , SumToJSON enc arity (C1 c a) allNullary

717− ) => GToJSON enc arity (D1 d (C1 c a)) where

718− -- The option 'tagSingleConstructors' determines whether to wrap

719− -- a single-constructor type.

720− gToJSON opts targs

721− | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)

722− . sumToJSON opts targs

723− . unM1

724− | otherwise = consToJSON opts targs . unM1 . unM1

725− {-# INLINE gToJSON #-}

726−

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

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

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

730− gToJSON opts targs = consToJSON opts targs . unM1

731− {-# INLINE gToJSON #-}

732−

733−instance ( AllNullary (a :+: b) allNullary

734− , SumToJSON enc arity (a :+: b) allNullary

735− ) => GToJSON enc arity (a :+: b)

736− where

737− -- If all constructors of a sum datatype are nullary and the

738− -- 'allNullaryToStringTag' option is set they are encoded to

739− -- strings. This distinction is made by 'sumToJSON':

740− gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)

741− . sumToJSON opts targs

742− {-# INLINE gToJSON #-}

743−

744637--------------------------------------------------------------------------------

745638-- Generic toJSON

746639

747−-- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is

748−-- possible but makes error messages a bit harder to understand for missing

749−-- instances.

750−

751−instance GToJSON Value arity V1 where

752− -- Empty values do not exist, which makes the job of formatting them

753− -- rather easy:

754− gToJSON _ _ x = x `seq` error "case: V1"

755− {-# INLINE gToJSON #-}

640+instance OVERLAPPABLE_ (GToJSON arity a) => GToJSON arity (M1 i c a) where

641+ -- Meta-information, which is not handled elsewhere, is ignored:

642+ gToJSON opts targs = gToJSON opts targs . unM1

756643

757−instance ToJSON a => GToJSON Value arity (K1 i a) where

644+instance (ToJSON a) => GToJSON arity (K1 i a) where

758645 -- Constant values are encoded using their ToJSON instance:

759646 gToJSON _opts _ = toJSON . unK1

760− {-# INLINE gToJSON #-}

761647

762−instance ToJSON1 f => GToJSON Value One (Rec1 f) where

648+instance GToJSON One Par1 where

649+ -- Direct occurrences of the last type parameter are encoded with the

650+ -- function passed in as an argument:

651+ gToJSON _opts (To1Args tj _) = tj . unPar1

652+

653+instance (ToJSON1 f) => GToJSON One (Rec1 f) where

763654 -- Recursive occurrences of the last type parameter are encoded using their

764655 -- ToJSON1 instance:

765656 gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1

766− {-# INLINE gToJSON #-}

767657

768−instance GToJSON Value arity U1 where

658+instance GToJSON arity U1 where

769659 -- Empty constructors are encoded to an empty array:

770660 gToJSON _opts _ _ = emptyArray

771− {-# INLINE gToJSON #-}

661+

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

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

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

665+ gToJSON opts targs = consToJSON opts targs . unM1

772666

773667instance ( WriteProduct arity a, WriteProduct arity b

774668 , ProductSize a, ProductSize b

775− ) => GToJSON Value arity (a :*: b)

776− where

669+ ) => GToJSON arity (a :*: b) where

777670 -- Products are encoded to an array. Here we allocate a mutable vector of

778671 -- the same size as the product and write the product's elements to it using

779672 -- 'writeProduct':

@@ -785,175 +678,237 @@ instance ( WriteProduct arity a, WriteProduct arity b

785678 where

786679 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

787680 productSize

788− {-# INLINE gToJSON #-}

789681

790−instance ( ToJSON1 f

791− , GToJSON Value One g

792− ) => GToJSON Value One (f :.: g)

793− where

682+instance ( AllNullary (a :+: b) allNullary

683+ , SumToJSON arity (a :+: b) allNullary

684+ ) => GToJSON arity (a :+: b) where

685+ -- If all constructors of a sum datatype are nullary and the

686+ -- 'allNullaryToStringTag' option is set they are encoded to

687+ -- strings. This distinction is made by 'sumToJSON':

688+ gToJSON opts targs = (unTagged :: Tagged allNullary Value -> Value)

689+ . sumToJSON opts targs

690+

691+instance (ToJSON1 f, GToJSON One g) => GToJSON One (f :.: g) where

794692 -- If an occurrence of the last type parameter is nested inside two

795693 -- composed types, it is encoded by using the outermost type's ToJSON1

796694 -- instance to generically encode the innermost type:

797695 gToJSON opts targs =

798696 let gtj = gToJSON opts targs in

799697 liftToJSON gtj (listValue gtj) . unComp1

800− {-# INLINE gToJSON #-}

801698

802699--------------------------------------------------------------------------------

803700-- Generic toEncoding

804701

805−instance ToJSON a => GToJSON Encoding arity (K1 i a) where

702+instance OVERLAPPABLE_ (GToEncoding arity a) => GToEncoding arity (M1 i c a) where

703+ -- Meta-information, which is not handled elsewhere, is ignored:

704+ gToEncoding opts targs = gToEncoding opts targs . unM1

705+

706+instance (ToJSON a) => GToEncoding arity (K1 i a) where

806707 -- Constant values are encoded using their ToJSON instance:

807− gToJSON _opts _ = toEncoding . unK1

808− {-# INLINE gToJSON #-}

708+ gToEncoding _opts _ = toEncoding . unK1

709+

710+instance GToEncoding One Par1 where

711+ -- Direct occurrences of the last type parameter are encoded with the

712+ -- function passed in as an argument:

713+ gToEncoding _opts (To1Args te _) = te . unPar1

809714

810−instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where

715+instance (ToJSON1 f) => GToEncoding One (Rec1 f) where

811716 -- Recursive occurrences of the last type parameter are encoded using their

812717 -- ToEncoding1 instance:

813− gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1

814− {-# INLINE gToJSON #-}

718+ gToEncoding _opts (To1Args te tel) = liftToEncoding te tel . unRec1

815719

816−instance GToJSON Encoding arity U1 where

720+instance GToEncoding arity U1 where

817721 -- Empty constructors are encoded to an empty array:

818− gToJSON _opts _ _ = E.emptyArray_

819− {-# INLINE gToJSON #-}

722+ gToEncoding _opts _ _ = E.emptyArray_

723+

724+instance (ConsToEncoding arity a) => GToEncoding arity (C1 c a) where

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

726+ -- a record or not. This distinction is made by 'consToEncoding':

727+ gToEncoding opts targs = consToEncoding opts targs . unM1

820728

821729instance ( EncodeProduct arity a

822730 , EncodeProduct arity b

823− ) => GToJSON Encoding arity (a :*: b)

824− where

731+ ) => GToEncoding arity (a :*: b) where

825732 -- Products are encoded to an array. Here we allocate a mutable vector of

826733 -- the same size as the product and write the product's elements to it using

827734 -- 'encodeProduct':

828− gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]

829− {-# INLINE gToJSON #-}

735+ gToEncoding opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]

830736

831−instance ( ToJSON1 f

832− , GToJSON Encoding One g

833− ) => GToJSON Encoding One (f :.: g)

834− where

737+instance ( AllNullary (a :+: b) allNullary

738+ , SumToEncoding arity (a :+: b) allNullary

739+ ) => GToEncoding arity (a :+: b) where

740+ -- If all constructors of a sum datatype are nullary and the

741+ -- 'allNullaryToStringTag' option is set they are encoded to

742+ -- strings. This distinction is made by 'sumToEncoding':

743+ gToEncoding opts targs

744+ = (unTagged :: Tagged allNullary Encoding -> Encoding)

745+ . sumToEncoding opts targs

746+

747+instance (ToJSON1 f, GToEncoding One g) => GToEncoding One (f :.: g) where

835748 -- If an occurrence of the last type parameter is nested inside two

836749 -- composed types, it is encoded by using the outermost type's ToJSON1

837750 -- instance to generically encode the innermost type:

838− gToJSON opts targs =

839− let gte = gToJSON opts targs in

751+ gToEncoding opts targs =

752+ let gte = gToEncoding opts targs in

840753 liftToEncoding gte (listEncoding gte) . unComp1

841− {-# INLINE gToJSON #-}

842754

843755--------------------------------------------------------------------------------

844756

845−class SumToJSON enc arity f allNullary where

846− sumToJSON :: Options -> ToArgs enc arity a

847− -> f a -> Tagged allNullary enc

848−

849−instance ( GetConName f

850− , FromString enc

851− , TaggedObject enc arity f

852− , SumToJSON' ObjectWithSingleField enc arity f

853− , SumToJSON' TwoElemArray enc arity f

854− , SumToJSON' UntaggedValue enc arity f

855− ) => SumToJSON enc arity f True

856− where

757+class SumToJSON arity f allNullary where

758+ sumToJSON :: Options -> ToArgs Value arity a

759+ -> f a -> Tagged allNullary Value

760+

761+instance ( GetConName f

762+ , TaggedObjectPairs arity f

763+ , ObjectWithSingleFieldObj arity f

764+ , TwoElemArrayObj arity f

765+ , UntaggedValueObj arity f

766+ ) => SumToJSON arity f True where

857767 sumToJSON opts targs

858− | allNullaryToStringTag opts = Tagged . fromString

768+ | allNullaryToStringTag opts = Tagged . String . pack

859769 . constructorTagModifier opts . getConName

860770 | otherwise = Tagged . nonAllNullarySumToJSON opts targs

861771

862−instance ( TaggedObject enc arity f

863− , SumToJSON' ObjectWithSingleField enc arity f

864− , SumToJSON' TwoElemArray enc arity f

865− , SumToJSON' UntaggedValue enc arity f

866− ) => SumToJSON enc arity f False

867− where

772+instance ( TwoElemArrayObj arity f

773+ , TaggedObjectPairs arity f

774+ , ObjectWithSingleFieldObj arity f

775+ , UntaggedValueObj arity f

776+ ) => SumToJSON arity f False where

868777 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

869778

870−nonAllNullarySumToJSON :: ( TaggedObject enc arity f

871− , SumToJSON' ObjectWithSingleField enc arity f

872− , SumToJSON' TwoElemArray enc arity f

873− , SumToJSON' UntaggedValue enc arity f

874− ) => Options -> ToArgs enc arity a

875− -> f a -> enc

779+nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f

780+ , TaggedObjectPairs arity f

781+ , ObjectWithSingleFieldObj arity f

782+ , UntaggedValueObj arity f

783+ ) => Options -> ToArgs Value arity a

784+ -> f a -> Value

876785nonAllNullarySumToJSON opts targs =

877786 case sumEncoding opts of

878−

879787 TaggedObject{..} ->

880− taggedObject opts targs tagFieldName contentsFieldName

788+ object . taggedObjectPairs opts targs tagFieldName contentsFieldName

789+ ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs

790+ TwoElemArray -> Array . twoElemArrayObj opts targs

791+ UntaggedValue -> untaggedValueObj opts targs

881792

882− ObjectWithSingleField ->

883− (unTagged :: Tagged ObjectWithSingleField enc -> enc)

884− . sumToJSON' opts targs

885−

886− TwoElemArray ->

887− (unTagged :: Tagged TwoElemArray enc -> enc)

888− . sumToJSON' opts targs

793+--------------------------------------------------------------------------------

889794

890− UntaggedValue ->

891− (unTagged :: Tagged UntaggedValue enc -> enc)

892− . sumToJSON' opts targs

795+class SumToEncoding arity f allNullary where

796+ sumToEncoding :: Options -> ToArgs Encoding arity a

797+ -> f a -> Tagged allNullary Encoding

798+

799+instance ( GetConName f

800+ , TaggedObjectEnc arity f

801+ , ObjectWithSingleFieldEnc arity f

802+ , TwoElemArrayEnc arity f

803+ , UntaggedValueEnc arity f

804+ ) => SumToEncoding arity f True where

805+ sumToEncoding opts targs

806+ | allNullaryToStringTag opts = Tagged . toEncoding .

807+ constructorTagModifier opts . getConName

808+ | otherwise = Tagged . nonAllNullarySumToEncoding opts targs

809+

810+instance ( TwoElemArrayEnc arity f

811+ , TaggedObjectEnc arity f

812+ , ObjectWithSingleFieldEnc arity f

813+ , UntaggedValueEnc arity f

814+ ) => SumToEncoding arity f False where

815+ sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs

816+

817+nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f

818+ , TaggedObjectEnc arity f

819+ , ObjectWithSingleFieldEnc arity f

820+ , UntaggedValueEnc arity f

821+ ) => Options -> ToArgs Encoding arity a

822+ -> f a -> Encoding

823+nonAllNullarySumToEncoding opts targs =

824+ case sumEncoding opts of

825+ TaggedObject{..} ->

826+ taggedObjectEnc opts targs tagFieldName contentsFieldName

827+ ObjectWithSingleField -> objectWithSingleFieldEnc opts targs

828+ TwoElemArray -> twoElemArrayEnc opts targs

829+ UntaggedValue -> untaggedValueEnc opts targs

893830

894831--------------------------------------------------------------------------------

895832

896−class FromString enc where

897− fromString :: String -> enc

833+class TaggedObjectPairs arity f where

834+ taggedObjectPairs :: Options -> ToArgs Value arity a

835+ -> String -> String

836+ -> f a -> [Pair]

837+

838+instance ( TaggedObjectPairs arity a

839+ , TaggedObjectPairs arity b

840+ ) => TaggedObjectPairs arity (a :+: b) where

841+ taggedObjectPairs opts targs tagFieldName contentsFieldName (L1 x) =

842+ taggedObjectPairs opts targs tagFieldName contentsFieldName x

843+ taggedObjectPairs opts targs tagFieldName contentsFieldName (R1 x) =

844+ taggedObjectPairs opts targs tagFieldName contentsFieldName x

845+

846+instance ( IsRecord a isRecord

847+ , TaggedObjectPairs' arity a isRecord

848+ , Constructor c

849+ ) => TaggedObjectPairs arity (C1 c a) where

850+ taggedObjectPairs opts targs tagFieldName contentsFieldName =

851+ (pack tagFieldName .= constructorTagModifier opts

852+ (conName (undefined :: t c a p)) :) .

853+ (unTagged :: Tagged isRecord [Pair] -> [Pair]) .

854+ taggedObjectPairs' opts targs contentsFieldName . unM1

898855

899−instance FromString Encoding where

900− fromString = toEncoding

856+class TaggedObjectPairs' arity f isRecord where

857+ taggedObjectPairs' :: Options -> ToArgs Value arity a

858+ -> String -> f a -> Tagged isRecord [Pair]

901859

902−instance FromString Value where

903− fromString = String . pack

860+instance OVERLAPPING_ TaggedObjectPairs' arity U1 False where

861+ taggedObjectPairs' _ _ _ _ = Tagged []

904862

905−--------------------------------------------------------------------------------

863+instance (RecordToPairs arity f) => TaggedObjectPairs' arity f True where

864+ taggedObjectPairs' opts targs _ =

865+ Tagged . toList . recordToPairs opts targs

906866

907−class TaggedObject enc arity f where

908− taggedObject :: Options -> ToArgs enc arity a

909− -> String -> String

910− -> f a -> enc

867+instance (GToJSON arity f) => TaggedObjectPairs' arity f False where

868+ taggedObjectPairs' opts targs contentsFieldName =

869+ Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts targs

911870

912−instance ( TaggedObject enc arity a

913− , TaggedObject enc arity b

914− ) => TaggedObject enc arity (a :+: b)

915− where

916− taggedObject opts targs tagFieldName contentsFieldName (L1 x) =

917− taggedObject opts targs tagFieldName contentsFieldName x

918− taggedObject opts targs tagFieldName contentsFieldName (R1 x) =

919− taggedObject opts targs tagFieldName contentsFieldName x

920−

921−instance ( IsRecord a isRecord

922− , TaggedObject' enc pairs arity a isRecord

923− , FromPairs enc pairs

924− , FromString enc

925− , KeyValuePair enc pairs

871+--------------------------------------------------------------------------------

872+

873+class TaggedObjectEnc arity f where

874+ taggedObjectEnc :: Options -> ToArgs Encoding arity a

875+ -> String -> String

876+ -> f a -> Encoding

877+

878+instance ( TaggedObjectEnc arity a

879+ , TaggedObjectEnc arity b

880+ ) => TaggedObjectEnc arity (a :+: b) where

881+ taggedObjectEnc opts targs tagFieldName contentsFieldName (L1 x) =

882+ taggedObjectEnc opts targs tagFieldName contentsFieldName x

883+ taggedObjectEnc opts targs tagFieldName contentsFieldName (R1 x) =

884+ taggedObjectEnc opts targs tagFieldName contentsFieldName x

885+

886+instance ( IsRecord a isRecord

887+ , TaggedObjectEnc' arity a isRecord

926888 , Constructor c

927− ) => TaggedObject enc arity (C1 c a)

928− where

929− taggedObject opts targs tagFieldName contentsFieldName =

930− fromPairs . mappend tag . contents

889+ ) => TaggedObjectEnc arity (C1 c a) where

890+ taggedObjectEnc opts targs tagFieldName contentsFieldName v = E.pairs (E.pair key val)

931891 where

932− tag = tagFieldName `pair`

933− (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))

934− :: enc)

935− contents =

936− (unTagged :: Tagged isRecord pairs -> pairs) .

937− taggedObject' opts targs contentsFieldName . unM1

938−

939−class TaggedObject' enc pairs arity f isRecord where

940− taggedObject' :: Options -> ToArgs enc arity a

941− -> String -> f a -> Tagged isRecord pairs

942−

943−instance ( GToJSON enc arity f

944− , KeyValuePair enc pairs

945− ) => TaggedObject' enc pairs arity f False

946− where

947− taggedObject' opts targs contentsFieldName =

948− Tagged . (contentsFieldName `pair`) . gToJSON opts targs

892+ key :: Text

893+ key = pack tagFieldName

894+ val = toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))

895+ >< ((unTagged :: Tagged isRecord Encoding -> Encoding) . taggedObjectEnc' opts targs contentsFieldName . unM1 $ v)

949896

950−instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where

951− taggedObject' _ _ _ _ = Tagged mempty

897+class TaggedObjectEnc' arity f isRecord where

898+ taggedObjectEnc' :: Options -> ToArgs Encoding arity a

899+ -> String -> f a -> Tagged isRecord Encoding

952900

953−instance ( RecordToPairs enc pairs arity f

954− ) => TaggedObject' enc pairs arity f True

955− where

956− taggedObject' opts targs _ = Tagged . recordToPairs opts targs

901+instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where

902+ taggedObjectEnc' _ _ _ _ = Tagged E.empty

903+

904+instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where

905+ taggedObjectEnc' opts targs _ = Tagged . (E.comma ><) . fst

906+ . recordToEncoding opts targs

907+

908+instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where

909+ taggedObjectEnc' opts targs contentsFieldName =

910+ Tagged . (\z -> E.comma >< toEncoding contentsFieldName >< E.colon >< z) .

911+ gToEncoding opts targs

957912

958913--------------------------------------------------------------------------------

959914

@@ -968,38 +923,23 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where

968923instance (Constructor c) => GetConName (C1 c a) where

969924 getConName = conName

970925

971−-- For genericToJSONKey

972−instance GetConName a => GetConName (D1 d a) where

973− getConName (M1 x) = getConName x

974−

975926--------------------------------------------------------------------------------

976927

977−-- Reflection of SumEncoding variants

928+class TwoElemArrayObj arity f where

929+ twoElemArrayObj :: Options -> ToArgs Value arity a

930+ -> f a -> V.Vector Value

978931

979−data ObjectWithSingleField

980−data TwoElemArray

981−data UntaggedValue

932+instance ( TwoElemArrayObj arity a

933+ , TwoElemArrayObj arity b

934+ ) => TwoElemArrayObj arity (a :+: b) where

935+ twoElemArrayObj opts targs (L1 x) = twoElemArrayObj opts targs x

936+ twoElemArrayObj opts targs (R1 x) = twoElemArrayObj opts targs x

982937

983−--------------------------------------------------------------------------------

984−

985−class SumToJSON' s enc arity f where

986− sumToJSON' :: Options -> ToArgs enc arity a

987− -> f a -> Tagged s enc

988−

989−instance ( SumToJSON' s enc arity a

990− , SumToJSON' s enc arity b

991− ) => SumToJSON' s enc arity (a :+: b)

992− where

993− sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x

994− sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x

995−

996−--------------------------------------------------------------------------------

997−

998−instance ( GToJSON Value arity a

999− , ConsToJSON Value arity a

938+instance ( GToJSON arity a

939+ , ConsToJSON arity a

1000940 , Constructor c

1001− ) => SumToJSON' TwoElemArray Value arity (C1 c a) where

1002− sumToJSON' opts targs x = Tagged $ Array $ V.create $ do

941+ ) => TwoElemArrayObj arity (C1 c a) where

942+ twoElemArrayObj opts targs x = V.create $ do

1003943 mv <- VM.unsafeNew 2

1004944 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts

1005945 $ conName (undefined :: t c a p)

@@ -1008,121 +948,149 @@ instance ( GToJSON Value arity a

1008948

1009949--------------------------------------------------------------------------------

1010950

1011−instance ( GToJSON Encoding arity a

1012− , ConsToJSON Encoding arity a

951+class TwoElemArrayEnc arity f where

952+ twoElemArrayEnc :: Options -> ToArgs Encoding arity a

953+ -> f a -> Encoding

954+

955+instance ( TwoElemArrayEnc arity a

956+ , TwoElemArrayEnc arity b

957+ ) => TwoElemArrayEnc arity (a :+: b) where

958+ twoElemArrayEnc opts targs (L1 x) = twoElemArrayEnc opts targs x

959+ twoElemArrayEnc opts targs (R1 x) = twoElemArrayEnc opts targs x

960+

961+instance ( GToEncoding arity a

962+ , ConsToEncoding arity a

1013963 , Constructor c

1014− ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)

1015− where

1016− sumToJSON' opts targs x = Tagged $ E.list id

964+ ) => TwoElemArrayEnc arity (C1 c a) where

965+ twoElemArrayEnc opts targs x = E.list id

1017966 [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))

1018− , gToJSON opts targs x

967+ , gToEncoding opts targs x

1019968 ]

1020969

1021970--------------------------------------------------------------------------------

1022971

1023−class ConsToJSON enc arity f where

1024− consToJSON :: Options -> ToArgs enc arity a

1025− -> f a -> enc

972+class ConsToJSON arity f where

973+ consToJSON :: Options -> ToArgs Value arity a

974+ -> f a -> Value

1026975

1027−class ConsToJSON' enc arity f isRecord where

1028− consToJSON' :: Options -> ToArgs enc arity a

1029− -> f a -> Tagged isRecord enc

976+class ConsToJSON' arity f isRecord where

977+ consToJSON' :: Options -> ToArgs Value arity a

978+ -> Bool -- ^ Are we a record with one field?

979+ -> f a -> Tagged isRecord Value

1030980

1031−instance ( IsRecord f isRecord

1032− , ConsToJSON' enc arity f isRecord

1033− ) => ConsToJSON enc arity f

1034− where

981+instance ( IsRecord f isRecord

982+ , ConsToJSON' arity f isRecord

983+ ) => ConsToJSON arity f where

1035984 consToJSON opts targs =

1036− (unTagged :: Tagged isRecord enc -> enc)

1037− . consToJSON' opts targs

1038− {-# INLINE consToJSON #-}

985+ (unTagged :: Tagged isRecord Value -> Value)

986+ . consToJSON' opts targs (isUnary (undefined :: f a))

1039987

1040−instance OVERLAPPING_

1041− ( RecordToPairs enc pairs arity (S1 s f)

1042− , FromPairs enc pairs

1043− , GToJSON enc arity f

1044− ) => ConsToJSON' enc arity (S1 s f) True

1045− where

1046− consToJSON' opts targs

1047− | unwrapUnaryRecords opts = Tagged . gToJSON opts targs

1048− | otherwise = Tagged . fromPairs . recordToPairs opts targs

1049− {-# INLINE consToJSON' #-}

1050−

1051−instance ( RecordToPairs enc pairs arity f

1052− , FromPairs enc pairs

1053− ) => ConsToJSON' enc arity f True

1054− where

1055− consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs

1056− {-# INLINE consToJSON' #-}

988+instance (RecordToPairs arity f) => ConsToJSON' arity f True where

989+ consToJSON' opts targs isUn f = let

990+ vals = toList $ recordToPairs opts targs f

991+ in case (unwrapUnaryRecords opts,isUn,vals) of

992+ (True,True,[(_,val)]) -> Tagged val

993+ _ -> Tagged $ object vals

1057994

1058−instance GToJSON enc arity f => ConsToJSON' enc arity f False where

1059− consToJSON' opts targs = Tagged . gToJSON opts targs

1060− {-# INLINE consToJSON' #-}

995+instance GToJSON arity f => ConsToJSON' arity f False where

996+ consToJSON' opts targs _ = Tagged . gToJSON opts targs

1061997

1062998--------------------------------------------------------------------------------

1063999

1064−class RecordToPairs enc pairs arity f where

1065− -- 1st element: whole thing

1066− -- 2nd element: in case the record has only 1 field, just the value

1067− -- of the field (without the key); 'Nothing' otherwise

1068− recordToPairs :: Options -> ToArgs enc arity a

1069− -> f a -> pairs

1000+class ConsToEncoding arity f where

1001+ consToEncoding :: Options -> ToArgs Encoding arity a

1002+ -> f a -> Encoding

10701003

1071−instance ( Monoid pairs

1072− , RecordToPairs enc pairs arity a

1073− , RecordToPairs enc pairs arity b

1074− ) => RecordToPairs enc pairs arity (a :*: b)

1075− where

1076− recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =

1077− pairsOf a `mappend` pairsOf b

1078− where

1079− pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs

1080− pairsOf = recordToPairs opts targs

1081− {-# INLINE recordToPairs #-}

1082−

1083−instance ( Selector s

1084− , GToJSON enc arity a

1085− , KeyValuePair enc pairs

1086− ) => RecordToPairs enc pairs arity (S1 s a)

1087− where

1004+class ConsToEncoding' arity f isRecord where

1005+ consToEncoding' :: Options -> ToArgs Encoding arity a

1006+ -> Bool -- ^ Are we a record with one field?

1007+ -> f a -> Tagged isRecord Encoding

1008+

1009+instance ( IsRecord f isRecord

1010+ , ConsToEncoding' arity f isRecord

1011+ ) => ConsToEncoding arity f where

1012+ consToEncoding opts targs =

1013+ (unTagged :: Tagged isRecord Encoding -> Encoding)

1014+ . consToEncoding' opts targs (isUnary (undefined :: f a))

1015+

1016+instance (RecordToEncoding arity f) => ConsToEncoding' arity f True where

1017+ consToEncoding' opts targs isUn x =

1018+ let (enc, mbVal) = recordToEncoding opts targs x

1019+ in case (unwrapUnaryRecords opts, isUn, mbVal) of

1020+ (True, True, Just val) -> Tagged val

1021+ _ -> Tagged $ E.wrapObject enc

1022+

1023+instance GToEncoding arity f => ConsToEncoding' arity f False where

1024+ consToEncoding' opts targs _ = Tagged . gToEncoding opts targs

1025+

1026+--------------------------------------------------------------------------------

1027+

1028+class RecordToPairs arity f where

1029+ recordToPairs :: Options -> ToArgs Value arity a

1030+ -> f a -> DList Pair

1031+

1032+instance ( RecordToPairs arity a

1033+ , RecordToPairs arity b

1034+ ) => RecordToPairs arity (a :*: b) where

1035+ recordToPairs opts targs (a :*: b) = recordToPairs opts targs a <>

1036+ recordToPairs opts targs b

1037+

1038+instance (Selector s, GToJSON arity a) => RecordToPairs arity (S1 s a) where

10881039 recordToPairs = fieldToPair

1089− {-# INLINE recordToPairs #-}

1090−

1091−instance INCOHERENT_

1092− ( Selector s

1093− , GToJSON enc arity (K1 i (Maybe a))

1094− , KeyValuePair enc pairs

1095− , Monoid pairs

1096− ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))

1097− where

1040+

1041+instance OVERLAPPING_ (Selector s, ToJSON a) =>

1042+ RecordToPairs arity (S1 s (K1 i (Maybe a))) where

10981043 recordToPairs opts _ (M1 k1) | omitNothingFields opts

1099− , K1 Nothing <- k1 = mempty

1044+ , K1 Nothing <- k1 = DList.empty

11001045 recordToPairs opts targs m1 = fieldToPair opts targs m1

1101− {-# INLINE recordToPairs #-}

1102−

1103−instance INCOHERENT_

1104− ( Selector s

1105− , GToJSON enc arity (K1 i (Maybe a))

1106− , KeyValuePair enc pairs

1107− , Monoid pairs

1108− ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))

1109− where

1110− recordToPairs opts targs = recordToPairs opts targs . unwrap

1111− where

1112− unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p

1113− unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)

1114− {-# INLINE recordToPairs #-}

1115−

1116−fieldToPair :: (Selector s

1117− , GToJSON enc arity a

1118− , KeyValuePair enc pairs)

1119− => Options -> ToArgs enc arity p

1120− -> S1 s a p -> pairs

1121−fieldToPair opts targs m1 =

1122− let key = fieldLabelModifier opts (selName m1)

1123− value = gToJSON opts targs (unM1 m1)

1124− in key `pair` value

1125−{-# INLINE fieldToPair #-}

1046+

1047+fieldToPair :: (Selector s, GToJSON arity a)

1048+ => Options -> ToArgs Value arity p

1049+ -> S1 s a p -> DList Pair

1050+fieldToPair opts targs m1 = pure ( pack $ fieldLabelModifier opts $ selName m1

1051+ , gToJSON opts targs (unM1 m1)

1052+ )

1053+

1054+--------------------------------------------------------------------------------

1055+

1056+class RecordToEncoding arity f where

1057+ -- 1st element: whole thing

1058+ -- 2nd element: in case the record has only 1 field, just the value

1059+ -- of the field (without the key); 'Nothing' otherwise

1060+ recordToEncoding :: Options -> ToArgs Encoding arity a

1061+ -> f a -> (Encoding, Maybe Encoding)

1062+

1063+instance ( RecordToEncoding arity a

1064+ , RecordToEncoding arity b

1065+ ) => RecordToEncoding arity (a :*: b) where

1066+ recordToEncoding opts targs (a :*: b) | omitNothingFields opts =

1067+ (E.econcat $ intersperse E.comma $

1068+ filter (not . E.nullEncoding)

1069+ [ fst (recordToEncoding opts targs a)

1070+ , fst (recordToEncoding opts targs b) ]

1071+ , Nothing)

1072+ recordToEncoding opts targs (a :*: b) =

1073+ (fst (recordToEncoding opts targs a) >< E.comma ><

1074+ fst (recordToEncoding opts targs b),

1075+ Nothing)

1076+

1077+

1078+instance (Selector s, GToEncoding arity a) => RecordToEncoding arity (S1 s a) where

1079+ recordToEncoding = fieldToEncoding

1080+

1081+instance OVERLAPPING_ (Selector s, ToJSON a) =>

1082+ RecordToEncoding arity (S1 s (K1 i (Maybe a))) where

1083+ recordToEncoding opts _ (M1 k1) | omitNothingFields opts

1084+ , K1 Nothing <- k1 = (E.empty, Nothing)

1085+ recordToEncoding opts targs m1 = fieldToEncoding opts targs m1

1086+

1087+fieldToEncoding :: (Selector s, GToEncoding arity a)

1088+ => Options -> ToArgs Encoding arity p

1089+ -> S1 s a p -> (Encoding, Maybe Encoding)

1090+fieldToEncoding opts targs m1 =

1091+ let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)

1092+ valueBuilder = gToEncoding opts targs (unM1 m1)

1093+ in (keyBuilder >< E.colon >< valueBuilder, Just valueBuilder)

11261094

11271095--------------------------------------------------------------------------------

11281096

@@ -1145,12 +1113,10 @@ instance ( WriteProduct arity a

11451113 lenL = len `unsafeShiftR` 1

11461114 lenR = len - lenL

11471115 ixR = ix + lenL

1148− {-# INLINE writeProduct #-}

11491116

1150−instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where

1117+instance OVERLAPPABLE_ (GToJSON arity a) => WriteProduct arity a where

11511118 writeProduct opts targs mv ix _ =

11521119 VM.unsafeWrite mv ix . gToJSON opts targs

1153− {-# INLINE writeProduct #-}

11541120

11551121--------------------------------------------------------------------------------

11561122

@@ -1168,41 +1134,110 @@ instance ( EncodeProduct arity a

11681134 encodeProduct opts targs (a :*: b) =

11691135 encodeProduct opts targs a >*<

11701136 encodeProduct opts targs b

1171− {-# INLINE encodeProduct #-}

11721137

1173−instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where

1174− encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a

1175− {-# INLINE encodeProduct #-}

1138+instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where

1139+ encodeProduct opts targs a = E.retagEncoding $ gToEncoding opts targs a

11761140

11771141--------------------------------------------------------------------------------

11781142

1179−instance ( GToJSON enc arity a

1180− , ConsToJSON enc arity a

1181− , FromPairs enc pairs

1182− , KeyValuePair enc pairs

1143+class ObjectWithSingleFieldObj arity f where

1144+ objectWithSingleFieldObj :: Options -> ToArgs Value arity a

1145+ -> f a -> Object

1146+

1147+instance ( ObjectWithSingleFieldObj arity a

1148+ , ObjectWithSingleFieldObj arity b

1149+ ) => ObjectWithSingleFieldObj arity (a :+: b) where

1150+ objectWithSingleFieldObj opts targs (L1 x) =

1151+ objectWithSingleFieldObj opts targs x

1152+ objectWithSingleFieldObj opts targs (R1 x) =

1153+ objectWithSingleFieldObj opts targs x

1154+

1155+instance ( GToJSON arity a

1156+ , ConsToJSON arity a

11831157 , Constructor c

1184− ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)

1185− where

1186− sumToJSON' opts targs =

1187− Tagged . fromPairs . (typ `pair`) . gToJSON opts targs

1158+ ) => ObjectWithSingleFieldObj arity (C1 c a) where

1159+ objectWithSingleFieldObj opts targs = H.singleton typ . gToJSON opts targs

11881160 where

1189− typ = constructorTagModifier opts $

1161+ typ = pack $ constructorTagModifier opts $

11901162 conName (undefined :: t c a p)

11911163

11921164--------------------------------------------------------------------------------

11931165

1166+class ObjectWithSingleFieldEnc arity f where

1167+ objectWithSingleFieldEnc :: Options -> ToArgs Encoding arity a

1168+ -> f a -> Encoding

1169+

1170+instance ( ObjectWithSingleFieldEnc arity a

1171+ , ObjectWithSingleFieldEnc arity b

1172+ ) => ObjectWithSingleFieldEnc arity (a :+: b) where

1173+ objectWithSingleFieldEnc opts targs (L1 x) =

1174+ objectWithSingleFieldEnc opts targs x

1175+ objectWithSingleFieldEnc opts targs (R1 x) =

1176+ objectWithSingleFieldEnc opts targs x

1177+

1178+instance ( GToEncoding arity a

1179+ , ConsToEncoding arity a

1180+ , Constructor c

1181+ ) => ObjectWithSingleFieldEnc arity (C1 c a) where

1182+ objectWithSingleFieldEnc opts targs v = E.pairs (E.pair key val)

1183+ where

1184+ key :: Text

1185+ key = pack (constructorTagModifier opts (conName (undefined :: t c a p)))

1186+ val :: Encoding' Value

1187+ val = gToEncoding opts targs v

1188+

1189+--------------------------------------------------------------------------------

1190+

1191+class UntaggedValueObj arity f where

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

1193+ -> f a -> Value

1194+

1195+instance

1196+ ( UntaggedValueObj arity a

1197+ , UntaggedValueObj arity b

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

1199+ where

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

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

1202+

11941203instance OVERLAPPABLE_

1195− ( ConsToJSON enc arity a

1196− ) => SumToJSON' UntaggedValue enc arity (C1 c a)

1204+ ( GToJSON arity a

1205+ , ConsToJSON arity a

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

1207+ untaggedValueObj = gToJSON

1208+

1209+instance OVERLAPPING_

1210+ ( Constructor c )

1211+ => UntaggedValueObj arity (C1 c U1)

11971212 where

1198− sumToJSON' opts targs = Tagged . gToJSON opts targs

1213+ untaggedValueObj opts _ _ = toJSON $

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

1215+

1216+--------------------------------------------------------------------------------

1217+

1218+class UntaggedValueEnc arity f where

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

1220+ -> f a -> Encoding

1221+instance

1222+ ( UntaggedValueEnc arity a

1223+ , UntaggedValueEnc arity b

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

1225+ where

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

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

1228+

1229+instance OVERLAPPABLE_

1230+ ( GToEncoding arity a

1231+ , ConsToEncoding arity a

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

1233+ where

1234+ untaggedValueEnc = gToEncoding

11991235

12001236instance OVERLAPPING_

1201− ( Constructor c

1202− , FromString enc

1203− ) => SumToJSON' UntaggedValue enc arity (C1 c U1)

1237+ ( Constructor c )

1238+ => UntaggedValueEnc arity (C1 c U1)

12041239 where

1205− sumToJSON' opts _ _ = Tagged . fromString $

1240+ untaggedValueEnc opts _ _ = toEncoding $

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

12071242

12081243-------------------------------------------------------------------------------

@@ -1276,13 +1311,6 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where

12761311 toEncoding = toEncoding2

12771312 {-# INLINE toEncoding #-}

12781313

1279−instance ToJSON Void where

1280− toJSON = absurd

1281− {-# INLINE toJSON #-}

1282−

1283− toEncoding = absurd

1284− {-# INLINE toEncoding #-}

1285−

12861314

12871315instance ToJSON Bool where

12881316 toJSON = Bool

@@ -1468,6 +1496,7 @@ instance ToJSONKey Int64 where

14681496 toJSONKey = toJSONKeyTextEnc E.int64Text

14691497 {-# INLINE toJSONKey #-}

14701498

1499+

14711500instance ToJSON Word where

14721501 toJSON = Number . fromIntegral

14731502 {-# INLINE toJSON #-}

@@ -1527,12 +1556,6 @@ instance ToJSONKey Word64 where

15271556 toJSONKey = toJSONKeyTextEnc E.word64Text

15281557 {-# INLINE toJSONKey #-}

15291558

1530−instance ToJSON CTime where

1531− toJSON (CTime i) = toJSON i

1532− {-# INLINE toJSON #-}

1533−

1534− toEncoding (CTime i) = toEncoding i

1535− {-# INLINE toEncoding #-}

15361559

15371560instance ToJSON Text where

15381561 toJSON = String

@@ -1966,32 +1989,6 @@ dotNetTime (DotNetTime t) = secs ++ formatMillis t ++ ")/"

19661989formatMillis :: (FormatTime t) => t -> String

19671990formatMillis = take 3 . formatTime defaultTimeLocale "%q"

19681991

1969−-------------------------------------------------------------------------------

1970−-- primitive

1971−-------------------------------------------------------------------------------

1972−

1973−instance ToJSON a => ToJSON (PM.Array a) where

1974− -- note: we could do better than this if vector exposed the data

1975− -- constructor in Data.Vector.

1976− toJSON = toJSON . Exts.toList

1977− toEncoding = toEncoding . Exts.toList

1978−

1979−instance ToJSON a => ToJSON (PM.SmallArray a) where

1980− toJSON = toJSON . Exts.toList

1981− toEncoding = toEncoding . Exts.toList

1982−

1983−#if (MIN_VERSION_primitive(0,6,4))

1984−instance (PM.Prim a,ToJSON a) => ToJSON (PM.PrimArray a) where

1985− toJSON = toJSON . Exts.toList

1986− toEncoding = toEncoding . Exts.toList

1987−

1988−#if !MIN_VERSION_primitive(0,7,0)

1989−instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where

1990− toJSON = toJSON . Exts.toList

1991− toEncoding = toEncoding . Exts.toList

1992−#endif

1993−#endif

1994−

19951992-------------------------------------------------------------------------------

19961993-- time

19971994-------------------------------------------------------------------------------

@@ -2040,11 +2037,10 @@ stringEncoding :: Encoding' Text -> Value

20402037stringEncoding = String

20412038 . T.dropAround (== '"')

20422039 . T.decodeLatin1

2043− . L.toStrict

2040+ . lazyToStrictByteString

20442041 . E.encodingToLazyByteString

20452042{-# INLINE stringEncoding #-}

20462043

2047−

20482044instance ToJSON NominalDiffTime where

20492045 toJSON = Number . realToFrac

20502046 {-# INLINE toJSON #-}

@@ -2052,58 +2048,6 @@ instance ToJSON NominalDiffTime where

20522048 toEncoding = E.scientific . realToFrac

20532049 {-# INLINE toEncoding #-}

20542050

2055−

2056−instance ToJSON DiffTime where

2057− toJSON = Number . realToFrac

2058− {-# INLINE toJSON #-}

2059−

2060− toEncoding = E.scientific . realToFrac

2061− {-# INLINE toEncoding #-}

2062−

2063−-- | Encoded as number

2064−instance ToJSON SystemTime where

2065− toJSON (MkSystemTime secs nsecs) =

2066− toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)

2067− toEncoding (MkSystemTime secs nsecs) =

2068− toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)

2069−

2070−instance ToJSON CalendarDiffTime where

2071− toJSON (CalendarDiffTime m nt) = object

2072− [ "months" .= m

2073− , "time" .= nt

2074− ]

2075− toEncoding (CalendarDiffTime m nt) = E.pairs

2076− ("months" .= m <> "time" .= nt)

2077−

2078−instance ToJSON CalendarDiffDays where

2079− toJSON (CalendarDiffDays m d) = object

2080− [ "months" .= m

2081− , "days" .= d

2082− ]

2083− toEncoding (CalendarDiffDays m d) = E.pairs

2084− ("months" .= m <> "days" .= d)

2085−

2086−instance ToJSON DayOfWeek where

2087− toJSON Monday = "monday"

2088− toJSON Tuesday = "tuesday"

2089− toJSON Wednesday = "wednesday"

2090− toJSON Thursday = "thursday"

2091− toJSON Friday = "friday"

2092− toJSON Saturday = "saturday"

2093− toJSON Sunday = "sunday"

2094−

2095−toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text

2096−toEncodingDayOfWeek Monday = E.unsafeToEncoding "\"monday\""

2097−toEncodingDayOfWeek Tuesday = E.unsafeToEncoding "\"tuesday\""

2098−toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""

2099−toEncodingDayOfWeek Thursday = E.unsafeToEncoding "\"thursday\""

2100−toEncodingDayOfWeek Friday = E.unsafeToEncoding "\"friday\""

2101−toEncodingDayOfWeek Saturday = E.unsafeToEncoding "\"saturday\""

2102−toEncodingDayOfWeek Sunday = E.unsafeToEncoding "\"sunday\""

2103−

2104−instance ToJSONKey DayOfWeek where

2105− toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek

2106−

21072051-------------------------------------------------------------------------------

21082052-- base Monoid/Semigroup

21092053-------------------------------------------------------------------------------

@@ -2847,26 +2791,27 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,

28472791 toEncoding = toEncoding2

28482792 {-# INLINE toEncoding #-}

28492793

2850−--------------------------------------------------------------------------------

2851−

2852−-- | Wrap a list of pairs as an object.

2853−class Monoid pairs => FromPairs enc pairs | enc -> pairs where

2854− fromPairs :: pairs -> enc

2855−

2856−instance (a ~ Value) => FromPairs (Encoding' a) Series where

2857− fromPairs = E.pairs

2858−

2859−instance FromPairs Value (DList Pair) where

2860− fromPairs = object . toList

2794+-------------------------------------------------------------------------------

2795+-- pre-bytestring-0.10 compatibility

2796+-------------------------------------------------------------------------------

28612797

2862−-- | Like 'KeyValue' but the value is already converted to JSON

2863−-- ('Value' or 'Encoding'), and the result actually represents lists of pairs

2864−-- so it can be readily concatenated.

2865−class Monoid kv => KeyValuePair v kv where

2866− pair :: String -> v -> kv

2798+{-# INLINE lazyToStrictByteString #-}

2799+lazyToStrictByteString :: L.ByteString -> S.ByteString

2800+#if MIN_VERSION_bytestring(0,10,0)

2801+lazyToStrictByteString = L.toStrict

2802+#else

2803+lazyToStrictByteString = packChunks

28672804

2868−instance (v ~ Value) => KeyValuePair v (DList Pair) where

2869− pair k v = DList.singleton (pack k .= v)

2805+-- packChunks is taken from the blaze-builder package.

28702806

2871−instance (e ~ Encoding) => KeyValuePair e Series where

2872− pair = E.pairStr

2807+-- | Pack the chunks of a lazy bytestring into a single strict bytestring.

2808+packChunks :: L.ByteString -> S.ByteString

2809+packChunks lbs = do

2810+ S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)

2811+ where

2812+ copyChunks !L.Empty !_pf = return ()

2813+ copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do

2814+ withForeignPtr fpbuf $ \pbuf ->

2815+ copyBytes pf (pbuf `plusPtr` o) l

2816+ copyChunks lbs' (pf `plusPtr` l)

2817+#endif

Makefiledeleted−2

@@ -1,2 +0,0 @@

1−lint:

2− ./run-hlint.sh --cpp-include include/ --cpp-file travis/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/

README.markdown+2−1

@@ -24,4 +24,5 @@ See what's changed in recent (and upcoming) releases:

2424

2525# Authors

2626

27−This library was originally written by Bryan O'Sullivan.

27+This library is written and maintained by Bryan O'Sullivan,

28+<bos@serpentine.com>.

aeson.cabal+62−102

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

11name: aeson

2−version: 1.4.6.0

2+version: 1.0.2.1

33license: BSD3

44license-file: LICENSE

55category: Text, Web, JSON

@@ -21,10 +21,23 @@ description:

2121 To get started, see the documentation for the @Data.Aeson@ module

2222 below.

2323 .

24+ Parsing performance on a late 2013 MacBook Pro (2.6GHz Core i7),

25+ running 64-bit GHC 7.10.1, for mostly-English tweets from Twitter's

26+ JSON search API:

27+ .

28+ * 6.4 KB payloads, English: 7570 msg\/sec (47.6 MB\/sec)

29+ .

30+ * 14.6 KB payloads, Japanese: 3261 msg\/sec (46.6 MB\/sec)

31+ .

32+ Encoding performance on the same machine and data:

33+ .

34+ * 6.4 KB payloads, English: 22738 msg\/sec (142.9 MB\/sec)

35+ .

36+ * 14.6 KB payloads, Japanese: 15911 msg\/sec (227.4 MB\/sec)

37+ .

2438 (A note on naming: in Greek mythology, Aeson was the father of Jason.)

2539

2640extra-source-files:

27− *.yaml

2841 README.markdown

2942 benchmarks/*.cabal

3043 benchmarks/*.hs

@@ -33,17 +46,14 @@ extra-source-files:

3346 benchmarks/Makefile

3447 benchmarks/Typed/*.hs

3548 benchmarks/json-data/*.json

36− cbits/*.c

49+ include/overlapping-compat.h

50+ include/incoherent-compat.h

3751 changelog.md

3852 examples/*.cabal

3953 examples/*.hs

4054 examples/Twitter/*.hs

41− ffi/Data/Aeson/Parser/*.hs

4255 include/*.h

43− tests/JSONTestSuite/test_parsing/*.json

44− tests/JSONTestSuite/test_transform/*.json

45− tests/golden/*.expected

46− pure/Data/Aeson/Parser/*.hs

56+ cbits/*.c

4757

4858flag developer

4959 description: operate in developer mode

@@ -60,14 +70,8 @@ flag bytestring-builder

6070 default: False

6171 manual: False

6272

63−flag cffi

64− description: Controls whether to include c-ffi bits or pure haskell. Default to False for security.

65− default: False

66− manual: True

67−

6873library

6974 default-language: Haskell2010

70− hs-source-dirs: . attoparsec-iso8601/

7175

7276 exposed-modules:

7377 Data.Aeson

@@ -76,12 +80,10 @@ library

7680 Data.Aeson.Text

7781 Data.Aeson.Types

7882 Data.Aeson.TH

79− Data.Aeson.QQ.Simple

8083

8184 Data.Aeson.Encoding.Internal

8285 Data.Aeson.Internal

8386 Data.Aeson.Internal.Time

84− Data.Aeson.Parser.Internal

8587

8688 -- Deprecated modules

8789 exposed-modules:

@@ -90,6 +92,7 @@ library

9092 other-modules:

9193 Data.Aeson.Encoding.Builder

9294 Data.Aeson.Internal.Functions

95+ Data.Aeson.Parser.Internal

9396 Data.Aeson.Parser.Unescape

9497 Data.Aeson.Parser.Time

9598 Data.Aeson.Types.FromJSON

@@ -97,62 +100,43 @@ library

97100 Data.Aeson.Types.ToJSON

98101 Data.Aeson.Types.Class

99102 Data.Aeson.Types.Internal

100− Data.Attoparsec.Time

101− Data.Attoparsec.Time.Internal

102103

103− -- GHC bundled libs

104104 build-depends:

105− base >= 4.7.0.0 && < 5,

106− bytestring >= 0.10.4.0 && < 0.11,

107− containers >= 0.5.5.1 && < 0.7,

108− deepseq >= 1.3.0.0 && < 1.5,

109− ghc-prim >= 0.2 && < 0.6,

110− template-haskell >= 2.9.0.0 && < 2.16,

111− text >= 1.2.3.0 && < 1.3,

112− time >= 1.4 && < 1.10

113−

114− if impl(ghc >= 8.0)

115− build-depends: bytestring >= 0.10.8.1

116−

117− -- Compat

118− build-depends:

119− base-compat >= 0.9.1 && < 0.12,

120− time-compat >= 1.9.2.2 && < 1.10

105+ attoparsec >= 0.13.0.1,

106+ base >= 4.5 && < 5,

107+ base-compat >= 0.9.1 && < 0.10,

108+ containers >= 0.2.4.1,

109+ deepseq >= 1.3,

110+ dlist >= 0.2,

111+ ghc-prim >= 0.2,

112+ hashable >= 1.1.2.0,

113+ scientific >= 0.3.4.7 && < 0.4,

114+ tagged >=0.8.3 && <0.9,

115+ template-haskell >= 2.7,

116+ text >= 1.1.1.0,

117+ time >= 1.1.1.4,

118+ time-locale-compat >= 0.1.1 && < 0.2,

119+ unordered-containers >= 0.2.5.0,

120+ uuid-types >= 1.0.3 && <1.1,

121+ vector >= 0.8

121122

122− if !impl(ghc >= 8.6)

123− build-depends:

124− contravariant >=1.4.1 && <1.6

123+ if flag(bytestring-builder)

124+ build-depends: bytestring >= 0.9 && < 0.10.4,

125+ bytestring-builder >= 0.10.4 && < 1

126+ else

127+ build-depends: bytestring >= 0.10.4

125128

126129 if !impl(ghc >= 8.0)

127130 -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9

128131 build-depends:

129− semigroups >= 0.18.5 && < 0.20,

130− transformers >= 0.3.0.0 && < 0.6,

131− transformers-compat >= 0.6.2 && < 0.7,

132+ semigroups >= 0.18.2 && < 0.19,

133+ transformers >= 0.2.2.0,

134+ transformers-compat >= 0.3,

132135 fail == 4.9.*

133136

134137 if !impl(ghc >= 7.10)

135138 -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8

136− build-depends: nats >= 1.1.1 && < 1.2,

137− void >= 0.7.2 && < 0.8

138−

139− -- cannot use latest version

140− build-depends:

141− unordered-containers >= 0.2.8.0 && < 0.3,

142−

143− -- not in LTS-12.10

144− tagged >= 0.8.5 && < 0.9,

145− primitive >= 0.6.3.0 && < 0.8

146−

147− -- Other dependencies

148− build-depends:

149− attoparsec >= 0.13.2.2 && < 0.14,

150− dlist >= 0.8.0.4 && < 0.9,

151− hashable >= 1.2.7.0 && < 1.4,

152− scientific >= 0.3.6.2 && < 0.4,

153− th-abstraction >= 0.2.8.0 && < 0.4,

154− uuid-types >= 1.0.3 && < 1.1,

155− vector >= 0.12.0.1 && < 0.13

139+ build-depends: nats >= 1 && < 1.2

156140

157141 ghc-options: -Wall

158142

@@ -166,78 +150,58 @@ library

166150 ghc-options: -O2

167151

168152 include-dirs: include

169− if impl(ghcjs) || !flag(cffi)

170− hs-source-dirs: pure

171− other-modules: Data.Aeson.Parser.UnescapePure

172− else

173− c-sources: cbits/unescape_string.c

174− cpp-options: -DCFFI

175− hs-source-dirs: ffi

176− other-modules: Data.Aeson.Parser.UnescapeFFI

153+ c-sources: cbits/unescape_string.c

177154

178155test-suite tests

179156 default-language: Haskell2010

180− type: exitcode-stdio-1.0

181− hs-source-dirs: tests ffi pure

182− main-is: Tests.hs

183− c-sources: cbits/unescape_string.c

184− ghc-options: -Wall -threaded -rtsopts

185−

157+ type: exitcode-stdio-1.0

158+ hs-source-dirs: tests

159+ main-is: Tests.hs

186160 other-modules:

187− Data.Aeson.Parser.UnescapeFFI

188− Data.Aeson.Parser.UnescapePure

189161 DataFamilies.Properties

190162 DataFamilies.Instances

191163 DataFamilies.Encoders

192164 DataFamilies.Types

193165 Encoders

194− ErrorMessages

195166 Functions

196167 Instances

197168 Options

198− PropUtils

199169 Properties

200− PropertyGeneric

201− PropertyKeys

202− PropertyRoundTrip

203− PropertyRTFunctors

204− PropertyTH

205− SerializationFormatSpec

206170 Types

207171 UnitTests

208172 UnitTests.NullaryConstructors

209173

174+ ghc-options: -Wall -threaded -rtsopts

175+

210176 build-depends:

211− QuickCheck >= 2.10.0.1 && < 2.14,

177+ HUnit,

178+ QuickCheck >= 2.7 && <2.9.3,

212179 aeson,

213− integer-logarithms >= 1 && <1.1,

214180 attoparsec,

215181 base,

216182 base-compat,

217− base-orphans >= 0.5.3 && <0.9,

183+ base-orphans >= 0.5.3 && <0.6,

218184 base16-bytestring,

219185 containers,

220186 directory,

221187 dlist,

222− Diff >= 0.4 && < 0.5,

223188 filepath,

224− generic-deriving >= 1.10 && < 1.14,

189+ generic-deriving >= 1.10 && < 1.12,

225190 ghc-prim >= 0.2,

226191 hashable >= 1.2.4.0,

227192 scientific,

228193 tagged,

229194 template-haskell,

230− tasty,

231− tasty-golden,

232− tasty-hunit,

233− tasty-quickcheck,

195+ test-framework,

196+ test-framework-hunit,

197+ test-framework-quickcheck2,

234198 text,

235199 time,

236− time-compat,

200+ time-locale-compat,

237201 unordered-containers,

238202 uuid-types,

239203 vector,

240− quickcheck-instances >= 0.3.21 && <0.4

204+ quickcheck-instances >=0.3.12

241205

242206 if flag(bytestring-builder)

243207 build-depends: bytestring >= 0.9 && < 0.10.4,

@@ -247,20 +211,16 @@ test-suite tests

247211

248212 if !impl(ghc >= 8.0)

249213 build-depends:

250− semigroups >= 0.18.2 && < 0.20,

214+ semigroups >= 0.18.2 && < 0.19,

251215 transformers >= 0.2.2.0,

252216 transformers-compat >= 0.3

253217

254218 if !impl(ghc >= 7.10)

255− build-depends: nats >=1 && <1.2,

256− void >=0.7.2 && <0.8

219+ build-depends: nats >=1 && <1.2

257220

258221 if impl(ghc >= 7.8)

259222 build-depends: hashable-time >= 0.2 && <0.3

260223

261− if flag(fast)

262− ghc-options: -fno-enable-rewrite-rules

263−

264224source-repository head

265225 type: git

266226 location: git://github.com/bos/aeson.git

attoparsec-iso8601/Data/Attoparsec/Time.hsdeleted−148

@@ -1,148 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−-- |

5−-- Module: Data.Aeson.Parser.Time

7−-- License: BSD3

8−-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

9−-- Stability: experimental

10−-- Portability: portable

11−--

12−-- Parsers for parsing dates and times.

13−

14−module Data.Attoparsec.Time

15− (

16− day

17− , localTime

18− , timeOfDay

19− , timeZone

20− , utcTime

21− , zonedTime

22− ) where

23−

24−import Prelude.Compat

25−

26−import Control.Applicative ((<|>))

27−import Control.Monad (void, when)

28−import Data.Attoparsec.Text as A

29−import Data.Attoparsec.Time.Internal (toPico)

30−import Data.Bits ((.&.))

31−import Data.Char (isDigit, ord)

32−import Data.Fixed (Pico)

33−import Data.Int (Int64)

34−import Data.Maybe (fromMaybe)

35−import Data.Time.Calendar (Day, fromGregorianValid)

36−import Data.Time.Clock (UTCTime(..))

37−import qualified Data.Text as T

38−import qualified Data.Time.LocalTime as Local

39−

40−-- | Parse a date of the form @[+,-]YYYY-MM-DD@.

41−day :: Parser Day

42−day = do

43− absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id

44− y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"

45− m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"

46− d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD"

47− maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)

48−

49−-- | Parse a two-digit integer (e.g. day of month, hour).

50−twoDigits :: Parser Int

51−twoDigits = do

52− a <- digit

53− b <- digit

54− let c2d c = ord c .&. 15

55− return $! c2d a * 10 + c2d b

56−

57−-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.

58−timeOfDay :: Parser Local.TimeOfDay

59−timeOfDay = do

60− h <- twoDigits

61− m <- char ':' *> twoDigits

62− s <- option 0 (char ':' *> seconds)

63− if h < 24 && m < 60 && s < 61

64− then return (Local.TimeOfDay h m s)

65− else fail "invalid time"

66−

67−data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64

68−

69−-- | Parse a count of seconds, with the integer part being two digits

70−-- long.

71−seconds :: Parser Pico

72−seconds = do

73− real <- twoDigits

74− mc <- peekChar

75− case mc of

76− Just '.' -> do

77− t <- anyChar *> takeWhile1 isDigit

78− return $! parsePicos real t

79− _ -> return $! fromIntegral real

80− where

81− parsePicos a0 t = toPico (fromIntegral (t' * 10^n))

82− where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t

83− step ma@(T m a) c

84− | m <= 0 = ma

85− | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)

86−

87−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

88−-- zero. (This makes some speedups possible.)

89−timeZone :: Parser (Maybe Local.TimeZone)

90−timeZone = do

91− let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)

92− maybeSkip ' '

93− ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'

94− if ch == 'Z'

95− then return Nothing

96− else do

97− h <- twoDigits

98− mm <- peekChar

99− m <- case mm of

100− Just ':' -> anyChar *> twoDigits

101− Just d | isDigit d -> twoDigits

102− _ -> return 0

103− let off | ch == '-' = negate off0

104− | otherwise = off0

105− off0 = h * 60 + m

106− case undefined of

107− _ | off == 0 ->

108− return Nothing

109− | off < -720 || off > 840 || m > 59 ->

110− fail "invalid time zone offset"

111− | otherwise ->

112− let !tz = Local.minutesToTimeZone off

113− in return (Just tz)

114−

115−-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.

116−-- The space may be replaced with a @T@. The number of seconds is optional

117−-- and may be followed by a fractional component.

118−localTime :: Parser Local.LocalTime

119−localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay

120− where daySep = satisfy (\c -> c == 'T' || c == ' ')

121−

122−-- | Behaves as 'zonedTime', but converts any time zone offset into a

123−-- UTC time.

124−utcTime :: Parser UTCTime

125−utcTime = do

126− lt@(Local.LocalTime d t) <- localTime

127− mtz <- timeZone

128− case mtz of

129− Nothing -> let !tt = Local.timeOfDayToTime t

130− in return (UTCTime d tt)

131− Just tz -> return $! Local.localTimeToUTC tz lt

132−

133−-- | Parse a date with time zone info. Acceptable formats:

134−--

135−-- @YYYY-MM-DD HH:MM Z@

136−-- @YYYY-MM-DD HH:MM:SS Z@

137−-- @YYYY-MM-DD HH:MM:SS.SSS Z@

138−--

139−-- The first space may instead be a @T@, and the second space is

140−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a

141−-- time zone offset of the form @+0000@ or @-08:00@, where the first

142−-- two digits are hours, the @:@ is optional and the second two digits

143−-- (also optional) are minutes.

144−zonedTime :: Parser Local.ZonedTime

145−zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

146−

147−utc :: Local.TimeZone

148−utc = Local.TimeZone 0 False ""

attoparsec-iso8601/Data/Attoparsec/Time/Internal.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−-- |

4−-- Module: Data.Aeson.Internal.Time

6−-- License: BSD3

7−-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

8−-- Stability: experimental

9−-- Portability: portable

10−

11−module Data.Attoparsec.Time.Internal

12− (

13− TimeOfDay64(..)

14− , fromPico

15− , toPico

16− , diffTimeOfDay64

17− , toTimeOfDay64

18− ) where

19−

20−import Prelude.Compat

21−

22−import Data.Int (Int64)

23−import Data.Time

24−import Unsafe.Coerce (unsafeCoerce)

25−

26−#if MIN_VERSION_time(1,6,0)

27−

28−import Data.Time.Clock (diffTimeToPicoseconds)

29−

30−#endif

31−

32−import Data.Fixed (Pico, Fixed(MkFixed))

33−

34−#if !MIN_VERSION_time(1,6,0)

35−

36−diffTimeToPicoseconds :: DiffTime -> Integer

37−diffTimeToPicoseconds = unsafeCoerce

38−

39−#endif

40−

41−toPico :: Integer -> Pico

42−toPico = MkFixed

43−

44−fromPico :: Pico -> Integer

45−fromPico (MkFixed i) = i

46−

47−-- | Like TimeOfDay, but using a fixed-width integer for seconds.

48−data TimeOfDay64 = TOD {-# UNPACK #-} !Int

49− {-# UNPACK #-} !Int

50− {-# UNPACK #-} !Int64

51−

52−posixDayLength :: DiffTime

53−posixDayLength = 86400

54−

55−diffTimeOfDay64 :: DiffTime -> TimeOfDay64

56−diffTimeOfDay64 t

57− | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength))

58− | otherwise = TOD (fromIntegral h) (fromIntegral m) s

59− where (h,mp) = pico t `quotRem` 3600000000000000

60− (m,s) = mp `quotRem` 60000000000000

61− pico = fromIntegral . diffTimeToPicoseconds

62−

63−toTimeOfDay64 :: TimeOfDay -> TimeOfDay64

64−toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))

attoparsec-iso8601/LICENSEdeleted−30

@@ -1,30 +0,0 @@

2−

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions

7−are met:

8−

9−1. Redistributions of source code must retain the above copyright

10− notice, this list of conditions and the following disclaimer.

11−

12−2. Redistributions in binary form must reproduce the above copyright

13− notice, this list of conditions and the following disclaimer in the

14− documentation and/or other materials provided with the distribution.

15−

16−3. Neither the name of the author nor the names of his contributors

17− may be used to endorse or promote products derived from this software

18− without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS

21−OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

22−WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

23−DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR

24−ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

25−DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

26−OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

27−HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,

28−STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN

29−ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

30−POSSIBILITY OF SUCH DAMAGE.

attoparsec-iso8601/README.mddeleted−19

@@ -1,19 +0,0 @@

1−Parsing of ISO 8601 dates.

2−

3−This package is used to parse dates in aeson. It is split into a

4−separate package to be shared by other projects that want to parse

5−dates like aeson does.

6−

7−For now, this project is located in the aeson repository and aeson

8−itself uses the source of this package without pulling in the package

9−as a dependency.

10−

11−## Stability

12−

13−Since aeson depends on this package we want to be very careful about

14−changing the format.

15−

16−There may be breaking changes if we find that the format is

17−incorrectly too lenient. We consider widening of the allowed input a

18−non-breaking addition since all previously valid input will still

19−parse correctly.

attoparsec-iso8601/attoparsec-iso8601.cabaldeleted−55

@@ -1,55 +0,0 @@

1−name: attoparsec-iso8601

2−version: 1.0.1.0

3−synopsis: Parsing of ISO 8601 dates, originally from aeson.

4−description: Parsing of ISO 8601 dates, originally from aeson.

5−license: BSD3

6−license-file: LICENSE

7−category: Parsing

10−author: Bryan O'Sullivan <bos@serpentine.com>

11−maintainer: Adam Bergmark <adam@bergmark.nl>

12−stability: experimental

13−cabal-version: >=1.10

14−homepage: https://github.com/bos/aeson

15−bug-reports: https://github.com/bos/aeson/issues

16−build-type: Simple

17−extra-source-files:

18− README.md

19−

20−flag developer

21− description: operate in developer mode

22− default: False

23− manual: True

24−

25−flag fast

26− description: compile without optimizations

27− default: False

28− manual: True

29−

30−library

31− hs-source-dirs: .

32− default-language: Haskell2010

33− ghc-options: -Wall

34− exposed-modules:

35− Data.Attoparsec.Time.Internal

36− Data.Attoparsec.Time

37− build-depends:

38− attoparsec >= 0.13.0.1,

39− base >= 4.7 && < 5,

40− base-compat >= 0.9.1 && < 0.12,

41− text >= 1.1.1.0,

42− time >= 1.1.1.4

43−

44− if flag(fast)

45− ghc-options: -O0

46− else

47− ghc-options: -O2

48−

49− if flag(developer)

50− ghc-options: -Werror

51− ghc-prof-options: -auto-all

52−

53−source-repository head

54− type: git

55− location: git://github.com/bos/aeson.git

attoparsec-iso8601/changelog.mddeleted−5

@@ -1,5 +0,0 @@

1−For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md](https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md).

2−

3−### 1.0.1.0

4−

5−* Fixes handling of `UTCTime` wrt. leap seconds , thanks to Adam Schønemann

benchmarks/AesonCompareAutoInstances.hsnew file+229

@@ -0,0 +1,229 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE TemplateHaskell #-}

5+module Main (main) where

7+import Prelude ()

8+import Prelude.Compat

10+import Control.DeepSeq (NFData, rnf, deepseq)

11+import Criterion.Main hiding (defaultOptions)

12+import Data.Aeson.Encode

13+import Data.Aeson.TH

14+import Data.Aeson.Types

15+import Data.Data (Data)

16+import Data.Typeable (Typeable)

17+import GHC.Generics (Generic)

18+import Options

19+import qualified Data.Aeson.Generic as G (fromJSON, toJSON)

20+

21+--------------------------------------------------------------------------------

22+

23+data D a = Nullary

24+ | Unary Int

25+ | Product String Char a

26+ | Record { testOne :: Double

27+ , testTwo :: Bool

28+ , testThree :: D a

29+ }

30+ deriving (Show, Eq, Data, Typeable)

31+

32+deriveJSON opts ''D

33+

34+instance NFData a => NFData (D a) where

35+ rnf Nullary = ()

36+ rnf (Unary n) = rnf n

37+ rnf (Product s c x) = s `deepseq` c `deepseq` rnf x

38+ rnf (Record d b y) = d `deepseq` b `deepseq` rnf y

39+

40+type T = D (D (D ()))

41+

42+d :: T

43+d = Record

44+ { testOne = 1234.56789

45+ , testTwo = True

46+ , testThree = Product "Hello World!" 'a' $

47+ Record

48+ { testOne = 9876.54321

49+ , testTwo = False

50+ , testThree = Product "Yeehaa!!!" '\n' Nullary

51+ }

52+ }

53+

54+--------------------------------------------------------------------------------

55+

56+data D' a = Nullary'

57+ | Unary' Int

58+ | Product' String Char a

59+ | Record' { testOne' :: Double

60+ , testTwo' :: Bool

61+ , testThree' :: D' a

62+ }

63+ deriving (Show, Eq, Generic, Data, Typeable)

64+

65+instance ToJSON a => ToJSON (D' a) where

66+ toJSON = genericToJSON opts

67+

68+instance FromJSON a => FromJSON (D' a) where

69+ parseJSON = genericParseJSON opts

70+

71+instance NFData a => NFData (D' a) where

72+ rnf Nullary' = ()

73+ rnf (Unary' n) = rnf n

74+ rnf (Product' s c x) = s `deepseq` c `deepseq` rnf x

75+ rnf (Record' d b y) = d `deepseq` b `deepseq` rnf y

76+

77+type T' = D' (D' (D' ()))

78+

79+d' :: T'

80+d' = Record'

81+ { testOne' = 1234.56789

82+ , testTwo' = True

83+ , testThree' = Product' "Hello World!" 'a' $

84+ Record'

85+ { testOne' = 9876.54321

86+ , testTwo' = False

87+ , testThree' = Product' "Yeehaa!!!" '\n' Nullary'

88+ }

89+ }

90+

91+--------------------------------------------------------------------------------

92+

93+data BigRecord = BigRecord

94+ { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int

95+ , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int

96+ , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

97+ , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

98+ , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

99+ } deriving (Show, Eq, Generic, Data, Typeable)

100+

101+instance NFData BigRecord

102+

103+bigRecord = BigRecord 1 2 3 4 5

104+ 6 7 8 9 10

105+ 11 12 13 14 15

106+ 16 17 18 19 20

107+ 21 22 23 24 25

108+

109+gBigRecordToJSON :: BigRecord -> Value

110+gBigRecordToJSON = genericToJSON opts

111+

112+gBigRecordFromJSON :: Value -> Result BigRecord

113+gBigRecordFromJSON = parse $ genericParseJSON opts

114+

115+thBigRecordToJSON :: BigRecord -> Value

116+thBigRecordToJSON = $(mkToJSON opts ''BigRecord)

117+

118+thBigRecordFromJSON :: Value -> Result BigRecord

119+thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord)

120+

121+--------------------------------------------------------------------------------

122+

123+data BigProduct = BigProduct

124+ !Int !Int !Int !Int !Int

125+ !Int !Int !Int !Int !Int

126+ !Int !Int !Int !Int !Int

127+ !Int !Int !Int !Int !Int

128+ !Int !Int !Int !Int !Int

129+ deriving (Show, Eq, Generic, Data, Typeable)

130+

131+instance NFData BigProduct

132+

133+bigProduct = BigProduct 1 2 3 4 5

134+ 6 7 8 9 10

135+ 11 12 13 14 15

136+ 16 17 18 19 20

137+ 21 22 23 24 25

138+

139+gBigProductToJSON :: BigProduct -> Value

140+gBigProductToJSON = genericToJSON opts

141+

142+gBigProductFromJSON :: Value -> Result BigProduct

143+gBigProductFromJSON = parse $ genericParseJSON opts

144+

145+thBigProductToJSON :: BigProduct -> Value

146+thBigProductToJSON = $(mkToJSON opts ''BigProduct)

147+

148+thBigProductFromJSON :: Value -> Result BigProduct

149+thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct)

150+

151+--------------------------------------------------------------------------------

152+

153+data BigSum = F01 | F02 | F03 | F04 | F05

154+ | F06 | F07 | F08 | F09 | F10

155+ | F11 | F12 | F13 | F14 | F15

156+ | F16 | F17 | F18 | F19 | F20

157+ | F21 | F22 | F23 | F24 | F25

158+ deriving (Show, Eq, Generic, Data, Typeable)

159+

160+instance NFData BigSum

161+

162+bigSum = F25

163+

164+gBigSumToJSON :: BigSum -> Value

165+gBigSumToJSON = genericToJSON opts

166+

167+gBigSumFromJSON :: Value -> Result BigSum

168+gBigSumFromJSON = parse $ genericParseJSON opts

169+

170+thBigSumToJSON :: BigSum -> Value

171+thBigSumToJSON = $(mkToJSON opts ''BigSum)

172+

173+thBigSumFromJSON :: Value -> Result BigSum

174+thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum)

175+

176+--------------------------------------------------------------------------------

177+

178+type FJ a = Value -> Result a

179+

180+main :: IO ()

181+main = defaultMain

182+ [ let v = toJSON d

183+ in (d, d', v) `deepseq`

184+ bgroup "D"

185+ [ group "toJSON" (nf toJSON d)

186+ (nf G.toJSON d)

187+ (nf toJSON d')

188+ , group "fromJSON" (nf ( fromJSON :: FJ T ) v)

189+ (nf (G.fromJSON :: FJ T ) v)

190+ (nf ( fromJSON :: FJ T') v)

191+ ]

192+ , let v = thBigRecordToJSON bigRecord

193+ in bigRecord `deepseq` v `deepseq`

194+ bgroup "BigRecord"

195+ [ group "toJSON" (nf thBigRecordToJSON bigRecord)

196+ (nf G.toJSON bigRecord)

197+ (nf gBigRecordToJSON bigRecord)

198+ , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)

199+ (nf (G.fromJSON :: FJ BigRecord) v)

200+ (nf (gBigRecordFromJSON :: FJ BigRecord) v)

201+ ]

202+ , let v = thBigProductToJSON bigProduct

203+ in bigProduct `deepseq` v `deepseq`

204+ bgroup "BigProduct"

205+ [ group "toJSON" (nf thBigProductToJSON bigProduct)

206+ (nf G.toJSON bigProduct)

207+ (nf gBigProductToJSON bigProduct)

208+ , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)

209+ (nf (G.fromJSON :: FJ BigProduct) v)

210+ (nf (gBigProductFromJSON :: FJ BigProduct) v)

211+ ]

212+ , let v = thBigSumToJSON bigSum

213+ in bigSum `deepseq` v `deepseq`

214+ bgroup "BigSum"

215+ [ group "toJSON" (nf thBigSumToJSON bigSum)

216+ (nf G.toJSON bigSum)

217+ (nf gBigSumToJSON bigSum)

218+ , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)

219+ (nf (G.fromJSON :: FJ BigSum) v)

220+ (nf (gBigSumFromJSON :: FJ BigSum) v)

221+ ]

222+ ]

223+

224+group n th syb gen = bcompare

225+ [ bgroup n [ bench "th" th

226+ , bench "syb" syb

227+ , bench "generic" gen

228+ ]

229+ ]

benchmarks/AesonEncode.hs+5−4

@@ -1,13 +1,14 @@

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

32{-# LANGUAGE OverloadedStrings #-}

54module Main (main) where

6+import Prelude ()

77import Prelude.Compat

99import Control.DeepSeq

10−import Control.Monad (forM_)

10+import Control.Exception

11+import Control.Monad

1112import Data.Aeson

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

1314import Data.Char (isDigit)

@@ -24,7 +25,7 @@ main = do

2425 (c:a) -> (c,a)

2526 [] -> error "Unexpected empty list"

2627 let count = read cnt :: Int

27− forM_ args $ \arg -> withFile arg ReadMode $ \h -> do

28+ forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do

2829 putStrLn $ arg ++ ":"

2930 let refill = B.hGet h 16384

3031 result0 <- parseWith refill json =<< refill

@@ -34,7 +35,7 @@ main = do

3435 start <- getCurrentTime

3536 let loop !n r

3637 | n >= count = return ()

37− | otherwise = {-# SCC "loop" #-}

38+ | otherwise = {-# SCC "loop" #-} do

3839 rnf (encode r) `seq` loop (n+1) r

3940 loop 0 r0

4041 delta <- flip diffUTCTime start `fmap` getCurrentTime

benchmarks/AesonFoldable.hs+42−14

@@ -1,14 +1,16 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

21{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE PackageImports #-}

44module Main (main) where

66import Criterion.Main

8+import Prelude ()

89import Prelude.Compat

910

1011import Data.Foldable (toList)

11−import qualified Data.Aeson as A

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

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

1214import qualified Data.Sequence as S

1315import qualified Data.Vector as V

1416import qualified Data.Vector.Unboxed as U

@@ -19,6 +21,10 @@ import qualified Data.Vector.Unboxed as U

1921

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

2123

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

25+ toJSON = error "do not use this"

26+ toEncoding = B.toEncoding . toList . getL

27+

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

2329 toJSON = error "do not use this"

2430 toEncoding = A.toEncoding . toList . getL

@@ -29,6 +35,10 @@ instance Foldable f => A.ToJSON (L f) where

2935

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

3137

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

39+ toJSON = error "do not use this"

40+ toEncoding = B.foldable . getF

41+

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

3343 toJSON = error "do not use this"

3444 toEncoding = A.foldable . getF

@@ -53,34 +63,52 @@ valueUVector = U.fromList valueList

5363-- Main

5464-------------------------------------------------------------------------------

5565

56−benchEncode

66+benchEncodeA

5767 :: A.ToJSON a

5868 => String

5969 -> a

6070 -> Benchmark

61−benchEncode name val

71+benchEncodeA name val

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

6373

74+benchEncodeB

75+ :: B.ToJSON a

76+ => String

77+ -> a

78+ -> Benchmark

79+benchEncodeB name val

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

81+

6482main :: IO ()

6583main = defaultMain

6684 [ bgroup "encode"

6785 [ bgroup "List"

68− [ benchEncode "-" valueList

69− , benchEncode "L" $ L valueList

70− , benchEncode "F" $ F valueList

86+ [ benchEncodeB "-" valueList

87+ , benchEncodeB "L" $ L valueList

88+ , benchEncodeB "F" $ F valueList

89+ , benchEncodeA "-" valueList

90+ , benchEncodeA "L" $ L valueList

91+ , benchEncodeA "F" $ F valueList

7192 ]

7293 , bgroup "Seq"

73− [ benchEncode "-" valueSeq

74− , benchEncode "L" $ L valueSeq

75− , benchEncode "F" $ F valueSeq

94+ [ benchEncodeB "-" valueSeq

95+ , benchEncodeB "L" $ L valueSeq

96+ , benchEncodeB "F" $ F valueSeq

97+ , benchEncodeA "-" valueSeq

98+ , benchEncodeA "L" $ L valueSeq

99+ , benchEncodeA "F" $ F valueSeq

76100 ]

77101 , bgroup "Vector"

78− [ benchEncode "-" valueVector

79− , benchEncode "L" $ L valueVector

80− , benchEncode "F" $ F valueVector

102+ [ benchEncodeB "-" valueVector

103+ , benchEncodeB "L" $ L valueVector

104+ , benchEncodeB "F" $ F valueVector

105+ , benchEncodeA "-" valueVector

106+ , benchEncodeA "L" $ L valueVector

107+ , benchEncodeA "F" $ F valueVector

81108 ]

82109 , bgroup "Vector.Unboxed"

83− [ benchEncode "-" valueUVector

110+ [ benchEncodeB "-" valueUVector

111+ , benchEncodeA "-" valueUVector

84112 ]

85113 ]

86114 ]

benchmarks/AesonMap.hs+56−39

@@ -1,11 +1,13 @@

11{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PackageImports #-}

34{-# LANGUAGE RankNTypes #-}

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

78module Main (main) where

10+import Prelude ()

911import Prelude.Compat

1012

1113import Control.DeepSeq

@@ -13,8 +15,9 @@ import Criterion.Main

1315import Data.Hashable

1416import Data.Proxy (Proxy (..))

1517import Data.Tagged (Tagged (..))

16−import Data.Aeson

17−import Data.Aeson.Types (fromJSONKeyCoerce)

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

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

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

1821import qualified Data.ByteString.Lazy as LBS

1922import qualified Data.HashMap.Strict as HM

2023import qualified Data.Map as M

@@ -44,10 +47,10 @@ instance NFData T1 where

4447instance Hashable T1 where

4548 hashWithSalt salt (T1 t) = hashWithSalt salt t

4649

47−instance FromJSON T1 where

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

49−instance FromJSONKey T1 where

50− fromJSONKey = FromJSONKeyText T1

50+instance B.FromJSON T1 where

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

52+instance B.FromJSONKey T1 where

53+ fromJSONKey = B.FromJSONKeyText T1

5154

5255-------------------------------------------------------------------------------

5356-- Coerce

@@ -61,10 +64,10 @@ instance NFData T2 where

6164instance Hashable T2 where

6265 hashWithSalt salt (T2 t) = hashWithSalt salt t

6366

64−instance FromJSON T2 where

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

66−instance FromJSONKey T2 where

67− fromJSONKey = fromJSONKeyCoerce

67+instance B.FromJSON T2 where

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

69+instance B.FromJSONKey T2 where

70+ fromJSONKey = B.fromJSONKeyCoerce

6871

6972-------------------------------------------------------------------------------

7073-- TextParser

@@ -78,10 +81,10 @@ instance NFData T3 where

7881instance Hashable T3 where

7982 hashWithSalt salt (T3 t) = hashWithSalt salt t

8083

81−instance FromJSON T3 where

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

83−instance FromJSONKey T3 where

84− fromJSONKey = FromJSONKeyTextParser (pure . T3)

84+instance B.FromJSON T3 where

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

86+instance B.FromJSONKey T3 where

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

8588

8689-------------------------------------------------------------------------------

8790-- Values

@@ -94,30 +97,40 @@ value1000 = value 1000

9497value10000 = value 10000

9598

9699encodedValue10 :: LBS.ByteString

97−encodedValue10 = encode value10

100+encodedValue10 = B.encode $ value10

98101

99102encodedValue100 :: LBS.ByteString

100−encodedValue100 = encode value100

103+encodedValue100 = B.encode $ value100

101104

102105encodedValue1000 :: LBS.ByteString

103−encodedValue1000 = encode value1000

106+encodedValue1000 = B.encode $ value1000

104107

105108encodedValue10000 :: LBS.ByteString

106−encodedValue10000 = encode value10000

109+encodedValue10000 = B.encode $ value10000

107110

108111-------------------------------------------------------------------------------

109112-- Helpers

110113-------------------------------------------------------------------------------

111114

112−decodeHM

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

115+decodeHMB

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

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

115−decodeHM _ = decode

118+decodeHMB _ = B.decode

116119

117−decodeMap

118− :: (FromJSON (M.Map k T.Text), Ord k)

120+decodeHMA

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

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

123+decodeHMA _ = A.decode

124+

125+decodeMapB

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

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

128+decodeMapB _ = B.decode

129+

130+decodeMapA

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

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

120−decodeMap _ = decode

133+decodeMapA _ = A.decode

121134

122135proxyText :: Proxy T.Text

123136proxyText = Proxy

@@ -143,14 +156,15 @@ benchDecodeHM

143156 -> LBS.ByteString

144157 -> Benchmark

145158benchDecodeHM name val = bgroup name

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

154168 ]

155169

156170benchDecodeMap

@@ -158,10 +172,11 @@ benchDecodeMap

158172 -> LBS.ByteString

159173 -> Benchmark

160174benchDecodeMap name val = bgroup name

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

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

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

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

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

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

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

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

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

165180 ]

166181

167182benchEncodeHM

@@ -169,7 +184,8 @@ benchEncodeHM

169184 -> HM.HashMap T.Text T.Text

170185 -> Benchmark

171186benchEncodeHM name val = bgroup name

172− [ bench "Text" $ nf encode val

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

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

173189 ]

174190

175191benchEncodeMap

@@ -177,7 +193,8 @@ benchEncodeMap

177193 -> HM.HashMap T.Text T.Text

178194 -> Benchmark

179195benchEncodeMap name val = bgroup name

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

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

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

181198 ]

182199 where

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

benchmarks/AesonParse.hs+5−3

@@ -1,12 +1,14 @@

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

32{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PackageImports #-}

55module Main (main) where

7+import Prelude ()

78import Prelude.Compat

9−import Data.Aeson

10+import "aeson-benchmarks" Data.Aeson

11+import Control.Exception

1012import Control.Monad

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

1214import Data.Time.Clock

@@ -19,7 +21,7 @@ main = do

1921 (bs:cnt:args) <- getArgs

2022 let count = read cnt :: Int

2123 blkSize = read bs

22− forM_ args $ \arg -> withFile arg ReadMode $ \h -> do

24+ forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do

2325 putStrLn $ arg ++ ":"

2426 start <- getCurrentTime

2527 let loop !good !bad

benchmarks/AesonTuples.hs+2−1

@@ -1,7 +1,8 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

1+module Main where

33module Main (main) where

5+import Prelude ()

56import Prelude.Compat

78import Control.DeepSeq (deepseq)

benchmarks/Auto/G/BigProduct.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−

3−module Auto.G.BigProduct where

4−

5−import Control.DeepSeq

6−import Data.Aeson

7−import GHC.Generics (Generic)

8−import Options

9−

10−data BigProduct = BigProduct

11− !Int !Int !Int !Int !Int

12− !Int !Int !Int !Int !Int

13− !Int !Int !Int !Int !Int

14− !Int !Int !Int !Int !Int

15− !Int !Int !Int !Int !Int

16− deriving (Show, Eq, Generic)

17−

18−instance NFData BigProduct where

19− rnf a = a `seq` ()

20−

21−instance ToJSON BigProduct where

22− toJSON = genericToJSON opts

23− toEncoding = genericToEncoding opts

24−

25−instance FromJSON BigProduct where

26− parseJSON = genericParseJSON opts

27−

28−bigProduct :: BigProduct

29−bigProduct = BigProduct 1 2 3 4 5

30− 6 7 8 9 10

31− 11 12 13 14 15

32− 16 17 18 19 20

33− 21 22 23 24 25

benchmarks/Auto/G/BigRecord.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−

3−module Auto.G.BigRecord where

4−

5−import Control.DeepSeq

6−import Data.Aeson

7−import GHC.Generics (Generic)

8−import Options

9−

10−data BigRecord = BigRecord

11− { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int

12− , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int

13− , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

14− , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

15− , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

16− } deriving (Show, Eq, Generic)

17−

18−instance NFData BigRecord where

19− rnf a = a `seq` ()

20−

21−instance ToJSON BigRecord where

22− toJSON = genericToJSON opts

23− toEncoding = genericToEncoding opts

24−

25−instance FromJSON BigRecord where

26− parseJSON = genericParseJSON opts

27−

28−bigRecord :: BigRecord

29−bigRecord = BigRecord 1 2 3 4 5

30− 6 7 8 9 10

31− 11 12 13 14 15

32− 16 17 18 19 20

33− 21 22 23 24 25

benchmarks/Auto/G/BigSum.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−

3−module Auto.G.BigSum where

4−

5−import Control.DeepSeq

6−import Data.Aeson

7−import GHC.Generics (Generic)

8−import Options

9−

10−data BigSum = F01 | F02 | F03 | F04 | F05

11− | F06 | F07 | F08 | F09 | F10

12− | F11 | F12 | F13 | F14 | F15

13− | F16 | F17 | F18 | F19 | F20

14− | F21 | F22 | F23 | F24 | F25

15− deriving (Show, Eq, Generic)

16−

17−instance NFData BigSum where

18− rnf a = a `seq` ()

19−

20−instance ToJSON BigSum where

21− toJSON = genericToJSON opts

22− toEncoding = genericToEncoding opts

23−

24−instance FromJSON BigSum where

25− parseJSON = genericParseJSON opts

26−

27−bigSum :: BigSum

28−bigSum = F25

benchmarks/Auto/G/D.hsdeleted−44

@@ -1,44 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−

3−module Auto.G.D where

4−

5−import Control.DeepSeq

6−import Data.Aeson

7−import GHC.Generics (Generic)

8−import Options

9−

10−data D a = Nullary

11− | Unary Int

12− | Product String Char a

13− | Record { testOne :: Double

14− , testTwo :: Bool

15− , testThree :: D a

16− }

17− deriving (Show, Eq, Generic)

18−

19−instance NFData a => NFData (D a) where

20− rnf Nullary = ()

21− rnf (Unary n) = rnf n

22− rnf (Product s c x) = s `deepseq` c `deepseq` rnf x

23− rnf (Record a b y) = a `deepseq` b `deepseq` rnf y

24−

25−instance ToJSON a => ToJSON (D a) where

26− toJSON = genericToJSON opts

27− toEncoding = genericToEncoding opts

28−

29−instance FromJSON a => FromJSON (D a) where

30− parseJSON = genericParseJSON opts

31−

32−type T = D (D (D ()))

33−

34−d :: T

35−d = Record

36− { testOne = 1234.56789

37− , testTwo = True

38− , testThree = Product "Hello World!" 'a'

39− Record

40− { testOne = 9876.54321

41− , testTwo = False

42− , testThree = Product "Yeehaa!!!" '\n' Nullary

43− }

44− }

benchmarks/Auto/T/BigProduct.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Auto.T.BigProduct where

4−

5−import Control.DeepSeq

6−import Data.Aeson.TH

7−import Options

8−

9−data BigProduct = BigProduct

10− !Int !Int !Int !Int !Int

11− !Int !Int !Int !Int !Int

12− !Int !Int !Int !Int !Int

13− !Int !Int !Int !Int !Int

14− !Int !Int !Int !Int !Int

15− deriving (Show, Eq)

16−

17−instance NFData BigProduct where

18− rnf a = a `seq` ()

19−

20−deriveJSON opts ''BigProduct

21−

22−bigProduct :: BigProduct

23−bigProduct = BigProduct 1 2 3 4 5

24− 6 7 8 9 10

25− 11 12 13 14 15

26− 16 17 18 19 20

27− 21 22 23 24 25

benchmarks/Auto/T/BigRecord.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Auto.T.BigRecord where

4−

5−import Control.DeepSeq

6−import Data.Aeson.TH

7−import Options

8−

9−data BigRecord = BigRecord

10− { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int

11− , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int

12− , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

13− , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

14− , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

15− } deriving (Show, Eq)

16−

17−instance NFData BigRecord where

18− rnf a = a `seq` ()

19−

20−deriveJSON opts ''BigRecord

21−

22−bigRecord :: BigRecord

23−bigRecord = BigRecord 1 2 3 4 5

24− 6 7 8 9 10

25− 11 12 13 14 15

26− 16 17 18 19 20

27− 21 22 23 24 25

benchmarks/Auto/T/BigSum.hsdeleted−22

@@ -1,22 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Auto.T.BigSum where

4−

5−import Control.DeepSeq

6−import Data.Aeson.TH

7−import Options

8−

9−data BigSum = F01 | F02 | F03 | F04 | F05

10− | F06 | F07 | F08 | F09 | F10

11− | F11 | F12 | F13 | F14 | F15

12− | F16 | F17 | F18 | F19 | F20

13− | F21 | F22 | F23 | F24 | F25

14− deriving (Show, Eq)

15−

16−instance NFData BigSum where

17− rnf a = a `seq` ()

18−

19−deriveJSON opts ''BigSum

20−

21−bigSum :: BigSum

22−bigSum = F25

benchmarks/Auto/T/D.hsdeleted−38

@@ -1,38 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Auto.T.D where

4−

5−import Control.DeepSeq

6−import Data.Aeson.TH

7−import Options

8−

9−data D a = Nullary

10− | Unary Int

11− | Product String Char a

12− | Record { testOne :: Double

13− , testTwo :: Bool

14− , testThree :: D a

15− }

16− deriving (Show, Eq)

17−

18−instance NFData a => NFData (D a) where

19− rnf Nullary = ()

20− rnf (Unary n) = rnf n

21− rnf (Product s c x) = s `deepseq` c `deepseq` rnf x

22− rnf (Record a b y) = a `deepseq` b `deepseq` rnf y

23−

24−deriveJSON opts ''D

25−

26−type T = D (D (D ()))

27−

28−d :: T

29−d = Record

30− { testOne = 1234.56789

31− , testTwo = True

32− , testThree = Product "Hello World!" 'a'

33− Record

34− { testOne = 9876.54321

35− , testTwo = False

36− , testThree = Product "Yeehaa!!!" '\n' Nullary

37− }

38− }

benchmarks/AutoCompare.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# LANGUAGE RankNTypes #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−

4−module Main (main) where

5−

6−import Control.DeepSeq

7−import Control.Monad

8−import Criterion.Main

9−import Data.Aeson

10−

11−import qualified Auto.T.D as T

12−import qualified Auto.T.BigRecord as T

13−import qualified Auto.T.BigProduct as T

14−import qualified Auto.T.BigSum as T

15−import qualified Auto.G.D as G

16−import qualified Auto.G.BigRecord as G

17−import qualified Auto.G.BigProduct as G

18−import qualified Auto.G.BigSum as G

19−

20−--------------------------------------------------------------------------------

21−

22−runBench :: IO ()

23−runBench = defaultMain

24− [ compareBench "D" T.d G.d

25− , compareBench "BigRecord" T.bigRecord G.bigRecord

26− , compareBench "BigProduct" T.bigProduct G.bigProduct

27− , compareBench "BigSum" T.bigSum G.bigSum

28− ]

29−

30−group :: String -> Benchmarkable -> Benchmarkable -> Benchmark

31−group n th gen = bgroup n [ bench "th" th

32− , bench "generic" gen

33− ]

34−

35−compareBench

36− :: forall a b

37− . (ToJSON a, FromJSON a, NFData a, ToJSON b, FromJSON b, NFData b)

38− => String -> a -> b -> Benchmark

39−compareBench name a b = v `deepseq` bgroup name

40− [ group "toJSON" (nf toJSON a)

41− (nf toJSON b)

42− , group "encode" (nf encode a)

43− (nf encode b)

44− , group "fromJSON" (nf (fromJSON :: Value -> Result a) v)

45− (nf (fromJSON :: Value -> Result b) v)

46− ] where

47− v = toJSON a -- == toJSON b

48−

49−sanityCheck :: IO ()

50−sanityCheck = do

51− check T.d

52− check G.d

53− check T.bigRecord

54− check G.bigRecord

55− check T.bigProduct

56− check G.bigProduct

57− check T.bigSum

58− check G.bigSum

59−

60−check :: (Show a, Eq a, FromJSON a, ToJSON a)

61− => a -> IO ()

62−check x = do

63− unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x

64− unless (Success x == (decode_ . encode) x) $ fail $ "encode: " ++ show x

65− where

66− decode_ s = case decode s of

67− Just v -> fromJSON v

68− Nothing -> fail ""

69−

70−main :: IO ()

71−main = do

72− sanityCheck

73− runBench

benchmarks/Compare.hs+5−10

@@ -1,25 +1,22 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE PackageImports #-}

32{-# LANGUAGE ScopedTypeVariables #-}

54module Main (main) where

6+import Prelude ()

77import Prelude.Compat

99import Compare.BufferBuilder ()

10+import Compare.JsonBuilder ()

1011import Criterion.Main

1112import Data.BufferBuilder.Json

13+import Data.Json.Builder

1214import Twitter

1315import Twitter.Manual ()

1416import Typed.Common

15−import qualified Data.Aeson as Aeson

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

1618import qualified Compare.JsonBench as JsonBench

1719

18−#ifdef MIN_VERSION_json_builder

19−import Data.Json.Builder

20−import Compare.JsonBuilder ()

21−#endif

22−

2320main :: IO ()

2421main =

2522 defaultMain [

@@ -27,9 +24,7 @@ main =

2724 bgroup "twitter" [

2825 bench "aeson" $ nf Aeson.encode twtr

2926 , bench "buffer-builder" $ nf encodeJson twtr

30−#ifdef MIN_VERSION_json_builder

3127 , bench "json-builder" $ nf toJsonLBS twtr

32−#endif

3328 ]

3429 , JsonBench.benchmarks

3530 ]

benchmarks/Compare/BufferBuilder.hs+3−2

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21{-# LANGUAGE OverloadedStrings #-}

32{-# LANGUAGE RecordWildCards #-}

@@ -7,11 +6,13 @@

87module Compare.BufferBuilder () where

10−import Prelude.Compat hiding ((<>))

9+import Prelude ()

10+import Prelude.Compat

1111

1212import Data.BufferBuilder.Json

1313import Data.Int (Int64)

1414import Data.Monoid ((<>))

15+import Prelude hiding (id)

1516import Twitter

1617import qualified Data.BufferBuilder.Utf8 as UB

1718

benchmarks/Compare/JsonBench.hs+10−18

@@ -1,18 +1,18 @@

1−{-# LANGUAGE CPP #-}

1+-- Adapted from a buffer-builder benchmark:

2+--

3+-- https://github.com/chadaustin/buffer-builder/blob/master/test.json

25{-# LANGUAGE BangPatterns #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

37{-# LANGUAGE MagicHash #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

58{-# LANGUAGE OverloadedStrings #-}

69{-# LANGUAGE RecordWildCards #-}

710{-# LANGUAGE ScopedTypeVariables #-}

811

9−-- Adapted from a buffer-builder benchmark:

10−--

11−-- https://github.com/chadaustin/buffer-builder/blob/master/test.json

12−

1312module Compare.JsonBench (benchmarks) where

1413

15−import Prelude.Compat hiding ((<>))

14+import Prelude ()

15+import Prelude.Compat

1616

1717import Control.DeepSeq (NFData(..))

1818import Criterion

@@ -20,13 +20,9 @@ import Data.Aeson ((.:))

2020import Data.Monoid ((<>))

2121import Data.Text (Text)

2222import Typed.Common (load)

23−import qualified Control.Monad.Fail as Fail

2423import qualified Data.Aeson as Aeson

2524import qualified Data.BufferBuilder.Json as Json

26−

27−#ifdef MIN_VERSION_json_builder

2825import qualified Data.Json.Builder as JB

29−#endif

3026

3127data EyeColor = Green | Blue | Brown

3228 deriving (Eq, Show)

@@ -69,10 +65,10 @@ instance NFData Gender where rnf !_ = ()

6965instance NFData Fruit where rnf !_ = ()

7066

7167instance NFData Friend where

72− rnf Friend {..} = rnf fId `seq` rnf fName

68+ rnf Friend {..} = (rnf fId) `seq` (rnf fName) `seq` ()

7369

7470instance NFData User where

75− rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit

71+ rnf User {..} = (rnf uId) `seq` (rnf uIndex) `seq` (rnf uGuid) `seq` (rnf uIsActive) `seq` (rnf uBalance) `seq` (rnf uPicture) `seq` (rnf uAge) `seq` (rnf uEyeColor) `seq` (rnf uName) `seq` (rnf uGender) `seq` (rnf uCompany) `seq` (rnf uEmail) `seq` (rnf uPhone) `seq` (rnf uAddress) `seq` (rnf uAbout) `seq` (rnf uRegistered) `seq` (rnf uLatitude) `seq` (rnf uLongitude) `seq` (rnf uTags) `seq` (rnf uFriends) `seq` (rnf uGreeting) `seq` (rnf uFavouriteFruit) `seq` ()

7672

7773eyeColorTable :: [(Text, EyeColor)]

7874eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]

@@ -83,7 +79,7 @@ genderTable = [("male", Male), ("female", Female)]

8379fruitTable :: [(Text, Fruit)]

8480fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]

8581

86−enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

82+enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

8783enumFromJson enumName table extract v = do

8884 s <- extract v

8985 case lookup s table of

@@ -273,7 +269,6 @@ instance Json.ToJson User where

273269 <> "greeting"# Json..=# uGreeting

274270 <> "favoriteFruit"# Json..=# uFavouriteFruit

275271

276−#ifdef MIN_VERSION_json_builder

277272---- json-builder instances ----

278273

279274instance JB.Value EyeColor where

@@ -325,7 +320,6 @@ instance JB.Value User where

325320 <> t "friends" `JB.row` uFriends

326321 <> t "greeting" `JB.row` uGreeting

327322 <> t "favoriteFruit" `JB.row` uFavouriteFruit

328−#endif

329323

330324benchmarks :: Benchmark

331325benchmarks = env (load "json-data/buffer-builder.json") $

@@ -333,7 +327,5 @@ benchmarks = env (load "json-data/buffer-builder.json") $

333327 bgroup "json-bench" [

334328 bench "aeson" $ nf Aeson.encode parsedUserList

335329 , bench "buffer-builder" $ nf Json.encodeJson parsedUserList

336−#ifdef MIN_VERSION_json_builder

337330 , bench "json-builder" $ nf JB.toJsonLBS parsedUserList

338−#endif

339331 ]

benchmarks/Compare/JsonBuilder.hs+3−2

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21{-# LANGUAGE RecordWildCards #-}

43{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

@@ -6,10 +5,12 @@

76module Compare.JsonBuilder () where

9−import Prelude.Compat hiding ((<>))

8+import Prelude ()

9+import Prelude.Compat

1010

1111import Data.Json.Builder

1212import Data.Monoid ((<>))

13+import Prelude hiding (id)

1314import Twitter

1415

1516instance JsObject Metadata where

benchmarks/CompareWithJSON.hs+21−33

@@ -1,20 +1,16 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

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

53module Main (main) where

5+import Prelude ()

76import Prelude.Compat

98import Blaze.ByteString.Builder (toLazyByteString)

109import Blaze.ByteString.Builder.Char.Utf8 (fromString)

1110import Control.DeepSeq (NFData(rnf))

1211import Criterion.Main

13−import Data.Maybe (fromMaybe)

1412import qualified Data.Aeson as A

1513import qualified Data.Aeson.Text as A

16−import qualified Data.Aeson.Parser.Internal as I

17−import qualified Data.ByteString as BS

1814import qualified Data.ByteString.Lazy as BL

1915import qualified Data.Text.Lazy as TL

2016import qualified Data.Text.Lazy.Builder as TLB

@@ -27,7 +23,7 @@ instance (NFData v) => NFData (J.JSObject v) where

2723instance NFData J.JSValue where

2824 rnf J.JSNull = ()

2925 rnf (J.JSBool b) = rnf b

30− rnf (J.JSRational a b) = rnf a `seq` rnf b

26+ rnf (J.JSRational a b) = rnf a `seq` rnf b `seq` ()

3127 rnf (J.JSString s) = rnf (J.fromJSString s)

3228 rnf (J.JSArray lst) = rnf lst

3329 rnf (J.JSObject o) = rnf o

@@ -38,18 +34,15 @@ decodeJ s =

3834 J.Ok v -> v

3935 J.Error _ -> error "fail to parse via JSON"

4036

41−decode :: BL.ByteString -> A.Value

42−decode s = fromMaybe (error "fail to parse via Aeson") $ A.decode s

43−

44−decode' :: BL.ByteString -> A.Value

45−decode' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s

46−

47−decodeS :: BS.ByteString -> A.Value

48−decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s

37+decodeA :: BL.ByteString -> A.Value

38+decodeA s = case A.decode s of

39+ Just v -> v

40+ Nothing -> error "fail to parse via Aeson"

4941

50−decodeIP :: BL.ByteString -> A.Value

51−decodeIP s = fromMaybe (error "fail to parse via Parser.decodeWith") $

52− I.decodeWith I.jsonEOF A.fromJSON s

42+decodeA' :: BL.ByteString -> A.Value

43+decodeA' s = case A.decode' s of

44+ Just v -> v

45+ Nothing -> error "fail to parse via Aeson"

5346

5447encodeJ :: J.JSValue -> BL.ByteString

5548encodeJ = toLazyByteString . fromString . J.encode

@@ -65,37 +58,32 @@ main = do

6558 let enFile = "json-data/twitter100.json"

6659 jpFile = "json-data/jp100.json"

6760 enA <- BL.readFile enFile

68− enS <- BS.readFile enFile

6961 enJ <- readFile enFile

7062 jpA <- BL.readFile jpFile

71− jpS <- BS.readFile jpFile

7263 jpJ <- readFile jpFile

7364 defaultMain [

7465 bgroup "decode" [

7566 bgroup "en" [

76− bench "aeson/lazy" $ nf decode enA

77− , bench "aeson/strict" $ nf decode' enA

78− , bench "aeson/stricter" $ nf decodeS enS

79− , bench "aeson/parser" $ nf decodeIP enA

80− , bench "json" $ nf decodeJ enJ

67+ bench "aeson/lazy" $ nf decodeA enA

68+ , bench "aeson/strict" $ nf decodeA' enA

69+ , bench "json" $ nf decodeJ enJ

8170 ]

8271 , bgroup "jp" [

83− bench "aeson" $ nf decode jpA

84− , bench "aeson/stricter" $ nf decodeS jpS

85− , bench "json" $ nf decodeJ jpJ

72+ bench "aeson" $ nf decodeA jpA

73+ , bench "json" $ nf decodeJ jpJ

8674 ]

8775 ]

8876 , bgroup "encode" [

8977 bgroup "en" [

90− bench "aeson-to-bytestring" $ nf A.encode (decode enA)

91− , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode enA)

92− , bench "aeson-to-text" $ nf encodeToText (decode enA)

78+ bench "aeson-to-bytestring" $ nf A.encode (decodeA enA)

79+ , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decodeA enA)

80+ , bench "aeson-to-text" $ nf encodeToText (decodeA enA)

9381 , bench "json" $ nf encodeJ (decodeJ enJ)

9482 ]

9583 , bgroup "jp" [

96− bench "aeson-to-bytestring" $ nf A.encode (decode jpA)

97− , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode jpA)

98− , bench "aeson-to-text" $ nf encodeToText (decode jpA)

84+ bench "aeson-to-bytestring" $ nf A.encode (decodeA jpA)

85+ , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decodeA jpA)

86+ , bench "aeson-to-text" $ nf encodeToText (decodeA jpA)

9987 , bench "json" $ nf encodeJ (decodeJ jpJ)

10088 ]

10189 ]

benchmarks/Dates.hs+9−10

@@ -1,7 +1,6 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

31module Main (main) where

3+import Prelude ()

54import Prelude.Compat

76import Criterion.Main

@@ -23,22 +22,22 @@ main = do

2322 defaultMain [

2423 bgroup "decode" [

2524 bgroup "UTCTime" [

26− env file1 $ \bs -> bench "whole" $ nf utcTime bs

27− , env file2 $ \bs -> bench "fractional" $ nf utcTime bs

25+ env file1 $ \ ~bs -> bench "whole" $ nf utcTime bs

26+ , env file2 $ \ ~bs -> bench "fractional" $ nf utcTime bs

2827 ]

2928 , bgroup "ZonedTime" [

30− env file1 $ \bs -> bench "whole" $ nf zTime bs

31− , env file2 $ \bs -> bench "fractional" $ nf zTime bs

29+ env file1 $ \ ~bs -> bench "whole" $ nf zTime bs

30+ , env file2 $ \ ~bs -> bench "fractional" $ nf zTime bs

3231 ]

3332 ]

3433 , bgroup "encode" [

3534 bgroup "UTCTime" [

36− env (utcTime <$> file1) $ \ts -> bench "whole" $ nf encode ts

37− , env (utcTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts

35+ env (utcTime <$> file1) $ \ ~ts -> bench "whole" $ nf encode ts

36+ , env (utcTime <$> file2) $ \ ~ts -> bench "fractional" $ nf encode ts

3837 ]

3938 , bgroup "ZonedTime" [

40− env (zTime <$> file1) $ \ts -> bench "whole" $ nf encode ts

41− , env (zTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts

39+ env (zTime <$> file1) $ \ ~ts -> bench "whole" $ nf encode ts

40+ , env (zTime <$> file2) $ \ ~ts -> bench "fractional" $ nf encode ts

4241 ]

4342 ]

4443 ]

benchmarks/Escape.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−

4−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

5−

6−module Main (main) where

7−

8−import Prelude.Compat

9−

10−import Criterion.Main

11−import qualified Data.Aeson.Parser.UnescapeFFI as FFI

12−import qualified Data.Aeson.Parser.UnescapePure as Pure

13−

14−import qualified Data.ByteString.Char8 as BS

15−import System.Environment (getArgs, withArgs)

16−

17−main :: IO ()

18−main = do

19− args_ <- getArgs

20− let (args, p, n) =

21− case args_ of

22− "--pattern" : p : args_ -> k p args_

23− _ -> k "\\\"" args_

24− k p args_ =

25− case args_ of

26− "--repeat" : n : args_ -> (args_, p, read n)

27− args_ -> (args_, p, 10000)

28− input = BS.concat $ replicate n $ BS.pack p

29− withArgs args $ defaultMain

30− [ bench "ffi" $ whnf FFI.unescapeText input

31− , bench "pure" $ whnf Pure.unescapeText input

32− ]

benchmarks/Issue673.hsdeleted−165

@@ -1,165 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−

4−module Main (

5− main,

6− input17,

7− input32,

8− input64,

9− input128,

10− input256,

11− input2048,

12− input4096,

13− input8192,

14− input16384,

15− ) where

16−

17−import Criterion.Main

18−import Prelude.Compat

19−import Data.Int (Int64)

20−import Data.Scientific (Scientific)

21−import Data.Semigroup ((<>))

22−import Data.Aeson.Parser (scientific)

23−

24−import qualified Data.Attoparsec.ByteString.Lazy as AttoL

25−import qualified Data.Attoparsec.ByteString.Char8 as Atto8

26−import qualified Data.Aeson as A

27−import qualified Data.ByteString as BS

28−import qualified Data.ByteString.Lazy as LBS

29−import qualified Data.ByteString.Lazy.Char8 as LBS8

30−

31−decodeInt :: LBS.ByteString -> Maybe Int

32−decodeInt = A.decode

33−

34−decodeString :: LBS.ByteString -> Maybe String

35−decodeString = A.decode

36−

37−decodeScientific :: LBS.ByteString -> Maybe Scientific

38−decodeScientific = A.decode

39−

40−decodeViaRead :: LBS.ByteString -> Integer

41−decodeViaRead = read . LBS8.unpack

42−

43−decodeAtto :: LBS.ByteString -> Maybe Scientific

44−decodeAtto

45− = parseOnly (scientific <* AttoL.endOfInput)

46− where

47− parseOnly p lbs = case AttoL.parse p lbs of

48− AttoL.Done _ r -> Just r

49− AttoL.Fail {} -> Nothing

50−

51−decodeAtto8 :: LBS.ByteString -> Maybe Scientific

52−decodeAtto8

53− = parseOnly (Atto8.scientific <* AttoL.endOfInput)

54− where

55− parseOnly p lbs = case AttoL.parse p lbs of

56− AttoL.Done _ r -> Just r

57− AttoL.Fail {} -> Nothing

58−

59−generate :: Int64 -> LBS.ByteString

60−generate n = LBS8.replicate n '1'

61−

62−input17 :: LBS.ByteString

63−input17 = generate 17

64−

65−input32 :: LBS.ByteString

66−input32 = generate 32

67−

68−input64 :: LBS.ByteString

69−input64 = generate 64

70−

71−input128 :: LBS.ByteString

72−input128 = generate 128

73−

74−input256 :: LBS.ByteString

75−input256 = generate 256

76−

77−input2048 :: LBS.ByteString

78−input2048 = generate 2048

79−

80−input4096 :: LBS.ByteString

81−input4096 = generate 4096

82−

83−input8192 :: LBS.ByteString

84−input8192 = generate 8192

85−

86−input16384 :: LBS.ByteString

87−input16384 = generate 16384

88−

89−

90−main :: IO ()

91−main = defaultMain

92− -- works on 64bit

93− [ benchPair "17" input17

94− -- , benchPair "32" input32

95− -- , benchPair "64" input64

96− -- , benchPair "128" input128

97− -- , benchPair "256" input256

98− , benchPair "2048" input2048

99− , benchPair "4096" input4096

100− , benchPair "8192" input8192

101− , benchPair "16384" input16384

102− ]

103− where

104− benchPair name input = bgroup name

105− [ bench "Int" $ whnf decodeInt input

106− , bench "Simple" $ whnf bsToIntegerSimple (LBS.toStrict input)

107− , bench "Optim" $ whnf bsToInteger (LBS.toStrict input)

108− , bench "Read" $ whnf decodeViaRead input

109− , bench "Scientific" $ whnf decodeScientific input

110− , bench "parserA" $ whnf decodeAtto input

111− , bench "parserS" $ whnf decodeAtto8 input

112− , bench "String" $ whnf decodeString $ "\"" <> input <> "\""

113− ]

114−

115−-------------------------------------------------------------------------------

116−-- better fromInteger

117−-------------------------------------------------------------------------------

118−

119−bsToInteger :: BS.ByteString -> Integer

120−bsToInteger bs

121− | l > 40 = valInteger 10 l [ fromIntegral (w - 48) | w <- BS.unpack bs ]

122− | otherwise = bsToIntegerSimple bs

123− where

124− l = BS.length bs

125−

126−bsToIntegerSimple :: BS.ByteString -> Integer

127−bsToIntegerSimple = BS.foldl' step 0 where

128− step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'

129−

130−-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b

131−-- digits are combined into a single radix b^2 digit. This process is

132−-- repeated until we are left with a single digit. This algorithm

133−-- performs well only on large inputs, so we use the simple algorithm

134−-- for smaller inputs.

135−valInteger :: Integer -> Int -> [Integer] -> Integer

136−valInteger = go

137− where

138− go :: Integer -> Int -> [Integer] -> Integer

139− go _ _ [] = 0

140− go _ _ [d] = d

141− go b l ds

142− | l > 40 = b' `seq` go b' l' (combine b ds')

143− | otherwise = valSimple b ds

144− where

145− -- ensure that we have an even number of digits

146− -- before we call combine:

147− ds' = if even l then ds else 0 : ds

148− b' = b * b

149− l' = (l + 1) `quot` 2

150−

151− combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)

152− where

153− d = d1 * b + d2

154− combine _ [] = []

155− combine _ [_] = errorWithoutStackTrace "this should not happen"

156−

157−-- The following algorithm is only linear for types whose Num operations

158−-- are in constant time.

159−valSimple :: Integer -> [Integer] -> Integer

160−valSimple base = go 0

161− where

162− go r [] = r

163− go r (d : ds) = r' `seq` go r' ds

164− where

165− r' = r * base + fromIntegral d

benchmarks/JsonParse.hs+2−3

@@ -1,11 +1,10 @@

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

32{-# LANGUAGE ScopedTypeVariables #-}

4−

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

75module Main (main) where

7+import Prelude ()

98import Prelude.Compat

109

1110import Control.DeepSeq

@@ -17,7 +16,7 @@ import Text.JSON

1716instance NFData JSValue where

1817 rnf JSNull = ()

1918 rnf (JSBool b) = rnf b

20− rnf (JSRational b r) = rnf b `seq` rnf r

19+ rnf (JSRational b r) = rnf b `seq` rnf r `seq` ()

2120 rnf (JSString s) = rnf (fromJSString s)

2221 rnf (JSArray vs) = rnf vs

2322 rnf (JSObject kvs) = rnf (fromJSObject kvs)

benchmarks/Micro.hs+6−8

@@ -1,13 +1,11 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

31module Main (main) where

3+import Prelude ()

54import Prelude.Compat

76import Criterion.Main

8−

9−-- Encoding is a newtype wrapper around Builder

10−import Data.Aeson.Encoding (text, string, encodingToLazyByteString)

7+import qualified Data.Aeson.Encoding.Builder as AB

8+import qualified Data.ByteString.Builder as B

119import qualified Data.Text as T

1210

1311main :: IO ()

@@ -15,8 +13,8 @@ main = do

1513 let txt = "append (append b (primBounded w1 x1)) (primBounded w2 x2)"

1614 defaultMain [

1715 bgroup "string" [

18− bench "text" $ nf (encodingToLazyByteString . text) (T.pack txt)

19− , bench "string direct" $ nf (encodingToLazyByteString . string) txt

20− , bench "string via text" $ nf (encodingToLazyByteString . text . T.pack) txt

16+ bench "text" $ nf (B.toLazyByteString . AB.text) (T.pack txt)

17+ , bench "string direct" $ nf (B.toLazyByteString . AB.string) txt

18+ , bench "string via text" $ nf (B.toLazyByteString . AB.text . T.pack) txt

2119 ]

2220 ]

benchmarks/Options.hs+4−1

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

1−module Options (opts) where

1+module Options () where

3+import Prelude ()

4+import Prelude.Compat

36import Data.Aeson.Types

benchmarks/ReadFile.hs+2−2

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

32{-# LANGUAGE OverloadedStrings #-}

54module Main (main) where

6+import Prelude ()

77import Prelude.Compat

99import Control.DeepSeq

@@ -20,7 +20,7 @@ import qualified Data.ByteString as B

2020main = do

2121 (cnt:args) <- getArgs

2222 let count = read cnt :: Int

23− forM_ args $ \arg -> withFile arg ReadMode $ \h -> do

23+ forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do

2424 putStrLn $ arg ++ ":"

2525 start <- getCurrentTime

2626 let loop !n

benchmarks/Typed.hs+1−5

@@ -1,7 +1,6 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

31module Main (main) where

3+import Prelude ()

54import Prelude.Compat

76import Criterion.Main

@@ -14,7 +13,4 @@ main = defaultMain [

1413 Generic.benchmarks

1514 , Manual.benchmarks

1615 , TH.benchmarks

17− , Generic.decodeBenchmarks

18− , Manual.decodeBenchmarks

19− , TH.decodeBenchmarks

2016 ]

benchmarks/Typed/Common.hs+8−1

@@ -1,16 +1,23 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE PackageImports #-}

34{-# OPTIONS_GHC -fno-warn-unused-imports #-}

56module Typed.Common (load) where

8+import Prelude ()

79import Prelude.Compat

810

911import Data.ByteString.Lazy as L

1012import System.Exit

1113import System.IO

1214

15+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

1316import Data.Aeson hiding (Result)

17+#else

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

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

20+#endif

1421

1522load :: FromJSON a => FilePath -> IO a

1623load fileName = do

benchmarks/Typed/Generic.hs+25−27

@@ -1,44 +1,42 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module Typed.Generic (benchmarks, decodeBenchmarks) where

1+{-# LANGUAGE PackageImports #-}

2+module Typed.Generic (benchmarks) where

4+import Prelude ()

55import Prelude.Compat

7−import Data.Aeson hiding (Result)

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

88import Criterion

99import Data.ByteString.Lazy as L

10−import Twitter.Generic

10+import Twitter.TH

1111import Typed.Common

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

13+

14+encodeDirectA :: Result -> L.ByteString

15+encodeDirectA = encode

1216

13−encodeDirect :: Result -> L.ByteString

14−encodeDirect = encode

17+encodeViaValueA :: Result -> L.ByteString

18+encodeViaValueA = encode . toJSON

1519

16−encodeViaValue :: Result -> L.ByteString

17−encodeViaValue = encode . toJSON

20+encodeDirectB :: Result -> L.ByteString

21+encodeDirectB = B.encode

22+

23+encodeViaValueB :: Result -> L.ByteString

24+encodeViaValueB = B.encode . B.toJSON

1825

1926benchmarks :: Benchmark

2027benchmarks =

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

22− bgroup "encodeGeneric" [

29+ bgroup "generic" [

2330 bgroup "direct" [

24− bench "twitter100" $ nf encodeDirect twitter100

25− , 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

2635 ]

2736 , bgroup "viaValue" [

28− bench "twitter100" $ nf encodeViaValue twitter100

29− , bench "jp100" $ nf encodeViaValue jp100

30− ]

31− ]

32−

33−decodeDirect :: L.ByteString -> Maybe Result

34−decodeDirect = decode

35−

36−decodeBenchmarks :: Benchmark

37−decodeBenchmarks =

38− env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

39− bgroup "decodeGeneric"

40− [ bgroup "direct"

41− [ bench "twitter100" $ nf decodeDirect twitter100

42− , bench "jp100" $ nf decodeDirect jp100

37+ bench "twitter100" $ nf encodeViaValueB twitter100

38+ , bench "jp100" $ nf encodeViaValueB jp100

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

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

4341 ]

4442 ]

benchmarks/Typed/Manual.hs+24−26

@@ -1,44 +1,42 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module Typed.Manual (benchmarks, decodeBenchmarks) where

1+{-# LANGUAGE PackageImports #-}

2+module Typed.Manual (benchmarks) where

4+import Prelude ()

55import Prelude.Compat

7−import Data.Aeson hiding (Result)

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

88import Criterion

99import Data.ByteString.Lazy as L

1010import Twitter.Manual

1111import Typed.Common

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

13+

14+encodeDirectA :: Result -> L.ByteString

15+encodeDirectA = encode

1216

13−encodeDirect :: Result -> L.ByteString

14−encodeDirect = encode

17+encodeViaValueA :: Result -> L.ByteString

18+encodeViaValueA = encode . toJSON

1519

16−encodeViaValue :: Result -> L.ByteString

17−encodeViaValue = encode . toJSON

20+encodeDirectB :: Result -> L.ByteString

21+encodeDirectB = B.encode

22+

23+encodeViaValueB :: Result -> L.ByteString

24+encodeViaValueB = B.encode . B.toJSON

1825

1926benchmarks :: Benchmark

2027benchmarks =

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

22− bgroup "encodeManual" [

29+ bgroup "manual" [

2330 bgroup "direct" [

24− bench "twitter100" $ nf encodeDirect twitter100

25− , 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

2635 ]

2736 , bgroup "viaValue" [

28− bench "twitter100" $ nf encodeViaValue twitter100

29− , bench "jp100" $ nf encodeViaValue jp100

30− ]

31− ]

32−

33−decodeDirect :: L.ByteString -> Maybe Result

34−decodeDirect = decode

35−

36−decodeBenchmarks :: Benchmark

37−decodeBenchmarks =

38− env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

39− bgroup "decodeManual"

40− [ bgroup "direct"

41− [ bench "twitter100" $ nf decodeDirect twitter100

42− , bench "jp100" $ nf decodeDirect jp100

37+ bench "twitter100" $ nf encodeViaValueB twitter100

38+ , bench "jp100" $ nf encodeViaValueB jp100

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

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

4341 ]

4442 ]

benchmarks/Typed/TH.hs+24−26

@@ -1,44 +1,42 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module Typed.TH (benchmarks, decodeBenchmarks) where

1+{-# LANGUAGE PackageImports #-}

2+module Typed.TH (benchmarks) where

4+import Prelude ()

55import Prelude.Compat

7−import Data.Aeson hiding (Result)

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

88import Criterion

99import Data.ByteString.Lazy as L

1010import Twitter.TH

1111import Typed.Common

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

13+

14+encodeDirectA :: Result -> L.ByteString

15+encodeDirectA = encode

1216

13−encodeDirect :: Result -> L.ByteString

14−encodeDirect = encode

17+encodeViaValueA :: Result -> L.ByteString

18+encodeViaValueA = encode . toJSON

1519

16−encodeViaValue :: Result -> L.ByteString

17−encodeViaValue = encode . toJSON

20+encodeDirectB :: Result -> L.ByteString

21+encodeDirectB = B.encode

22+

23+encodeViaValueB :: Result -> L.ByteString

24+encodeViaValueB = B.encode . B.toJSON

1825

1926benchmarks :: Benchmark

2027benchmarks =

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

22− bgroup "encodeTH" [

29+ bgroup "th" [

2330 bgroup "direct" [

24− bench "twitter100" $ nf encodeDirect twitter100

25− , 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

2635 ]

2736 , bgroup "viaValue" [

28− bench "twitter100" $ nf encodeViaValue twitter100

29− , bench "jp100" $ nf encodeViaValue jp100

30− ]

31− ]

32−

33−decodeDirect :: L.ByteString -> Maybe Result

34−decodeDirect = decode

35−

36−decodeBenchmarks :: Benchmark

37−decodeBenchmarks =

38− env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->

39− bgroup "decodeTH"

40− [ bgroup "direct"

41− [ bench "twitter100" $ nf decodeDirect twitter100

42− , bench "jp100" $ nf decodeDirect 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

4341 ]

4442 ]

benchmarks/aeson-benchmarks.cabal+62−183

@@ -1,21 +1,60 @@

11name: aeson-benchmarks

22version: 0

33build-type: Simple

4−cabal-version: >=1.10

5+cabal-version: >=1.8

67flag bytestring-builder

78 description: Depend on the bytestring-builder package for backwards compatibility.

89 default: False

910 manual: False

1011

11−flag local-aeson

12− description: Build the local version of aeson, to avoid rebuilding aeson's

13− reverse dependencies for benchmarking (statistics, criterion).

14− default: True

15− manual: True

16−

1712library

18− default-language: Haskell2010

13+ hs-source-dirs: .. .

14+ c-sources: ../cbits/unescape_string.c

15+ exposed-modules:

16+ Data.Aeson

17+ Data.Aeson.Encoding

18+ Data.Aeson.Encoding.Builder

19+ Data.Aeson.Encoding.Internal

20+ Data.Aeson.Internal

21+ Data.Aeson.Internal.Functions

22+ Data.Aeson.Internal.Time

23+ Data.Aeson.Parser

24+ Data.Aeson.Parser.Internal

25+ Data.Aeson.Parser.Time

26+ Data.Aeson.Parser.Unescape

27+ Data.Aeson.TH

28+ Data.Aeson.Text

29+ Data.Aeson.Types

30+ Data.Aeson.Types.Class

31+ Data.Aeson.Types.FromJSON

32+ Data.Aeson.Types.Generic

33+ Data.Aeson.Types.Internal

34+ Data.Aeson.Types.ToJSON

35+

36+ build-depends:

37+ attoparsec >= 0.13.0.1,

38+ base == 4.*,

39+ base-compat >= 0.9.1 && <0.10,

40+ time-locale-compat >=0.1.1 && <0.2,

41+ containers,

42+ deepseq,

43+ dlist >= 0.2,

44+ fail == 4.9.*,

45+ ghc-prim >= 0.2,

46+ hashable >= 1.1.2.0,

47+ mtl,

48+ scientific >= 0.3.4.7 && < 0.4,

49+ syb,

50+ tagged >=0.8.3 && <0.9,

51+ template-haskell >= 2.4,

52+ text >= 1.1.1.0,

53+ time,

54+ transformers,

55+ unordered-containers >= 0.2.3.0,

56+ uuid-types >= 1.0.3 && <1.1,

57+ vector >= 0.7.1

1958

2059 if flag(bytestring-builder)

2160 build-depends: bytestring >= 0.9 && < 0.10.4,

@@ -23,142 +62,22 @@ library

2362 else

2463 build-depends: bytestring >= 0.10.4

2564

26− if flag(local-aeson)

27−

28− hs-source-dirs: .. ../ffi ../pure ../attoparsec-iso8601

29− c-sources: ../cbits/unescape_string.c

30− build-depends:

31− attoparsec,

32− base,

33− base-compat,

34− containers,

35− deepseq,

36− dlist,

37− fail,

38− ghc-prim,

39− hashable,

40− mtl,

41− primitive,

42− scientific,

43− syb,

44− tagged,

45− template-haskell,

46− text,

47− th-abstraction,

48− time-compat,

49− time,

50− transformers,

51− unordered-containers,

52− uuid-types,

53− vector

54−

55− if !impl(ghc >= 8.6)

56− build-depends: contravariant

57−

58− if !impl(ghc >= 8.0)

59− -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9

60− build-depends: semigroups,

61− transformers-compat

65+ if impl(ghc >=7.8)

66+ cpp-options: -DHAS_COERCIBLE

6267

63− if !impl(ghc >= 7.10)

64− -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8

65− build-depends: nats,

66− void

68+ if !impl(ghc >= 8.0)

69+ -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9

70+ build-depends: semigroups >= 0.18.2 && < 0.19

6771

68− include-dirs: ../include

72+ include-dirs: ../include

6973

70− ghc-options: -O2 -Wall

71− cpp-options: -DGENERICS

72−

73− exposed-modules:

74− Data.Aeson

75− Data.Aeson.Encoding

76− Data.Aeson.Encoding.Builder

77− Data.Aeson.Encoding.Internal

78− Data.Aeson.Internal

79− Data.Aeson.Internal.Functions

80− Data.Aeson.Internal.Time

81− Data.Aeson.Parser

82− Data.Aeson.Parser.Internal

83− Data.Aeson.Parser.Time

84− Data.Aeson.Parser.Unescape

85− Data.Aeson.Parser.UnescapeFFI

86− Data.Aeson.Parser.UnescapePure

87− Data.Aeson.TH

88− Data.Aeson.Text

89− Data.Aeson.Types

90− Data.Aeson.Types.Class

91− Data.Aeson.Types.FromJSON

92− Data.Aeson.Types.Generic

93− Data.Aeson.Types.Internal

94− Data.Aeson.Types.ToJSON

95− Data.Attoparsec.Time

96− Data.Attoparsec.Time.Internal

97−

98− else

99−

100− build-depends: aeson

101−

102− reexported-modules:

103− Data.Aeson,

104− Data.Aeson.Encoding,

105− Data.Aeson.Parser.Internal,

106− Data.Aeson.Text,

107− Data.Aeson.TH,

108− Data.Aeson.Types

109−

110−executable aeson-benchmark-auto-compare

111− default-language: Haskell2010

112− main-is: AutoCompare.hs

113− hs-source-dirs: .

114− ghc-options: -Wall -O2 -rtsopts

115− other-modules:

116− Auto.T.D

117− Auto.T.BigRecord

118− Auto.T.BigProduct

119− Auto.T.BigSum

120− Auto.G.D

121− Auto.G.BigRecord

122− Auto.G.BigProduct

123− Auto.G.BigSum

124− Options

125− build-depends:

126− aeson-benchmarks,

127− base,

128− criterion,

129− deepseq,

130− template-haskell

131−

132−executable aeson-benchmark-escape

133− default-language: Haskell2010

134− main-is: Escape.hs

135− hs-source-dirs: ../examples .

136− ghc-options: -Wall -O2 -rtsopts

137− if flag(local-aeson)

138− build-depends:

139− aeson-benchmarks,

140− base,

141− base-compat,

142− bytestring,

143− criterion >= 1.0,

144− deepseq,

145− ghc-prim,

146− text

147− else

148− -- Disabled because of inaccessible internals

149− buildable: False

74+ ghc-options: -O2 -Wall

75+ cpp-options: -DGENERICS

15076

15177executable aeson-benchmark-compare

152− default-language: Haskell2010

15378 main-is: Compare.hs

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

15580 ghc-options: -Wall -O2 -rtsopts

156− other-modules:

157− Compare.BufferBuilder

158− Compare.JsonBench

159− Twitter

160− Twitter.Manual

161− Typed.Common

16281 build-depends:

16382 aeson-benchmarks,

16483 base,

@@ -168,19 +87,10 @@ executable aeson-benchmark-compare

16887 criterion >= 1.0,

16988 deepseq,

17089 ghc-prim,

90+ json-builder,

17191 text

17292

173− if impl(ghc < 8.4)

174− other-modules:

175− Compare.JsonBuilder

176− build-depends:

177− json-builder

178− if impl(ghc < 8.0)

179− build-depends:

180− semigroups

181−

18293executable aeson-benchmark-micro

183− default-language: Haskell2010

18494 main-is: Micro.hs

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

18696 ghc-options: -Wall -O2 -rtsopts

@@ -195,21 +105,14 @@ executable aeson-benchmark-micro

195105 text

196106

197107executable aeson-benchmark-typed

198− default-language: Haskell2010

199108 main-is: Typed.hs

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

201110 ghc-options: -Wall -O2 -rtsopts

202− other-modules:

203− Twitter

204− Twitter.Generic

205− Twitter.Manual

206− Twitter.Options

207− Twitter.TH

208− Typed.Common

209− Typed.Generic

210− Typed.Manual

211− Typed.TH

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

112+ -- aeson and aeson-benchmakrs

113+ cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS

212114 build-depends:

115+ aeson,

213116 aeson-benchmarks,

214117 base,

215118 base-compat,

@@ -224,11 +127,8 @@ executable aeson-benchmark-typed

224127 bytestring-builder >= 0.10.4 && < 1

225128 else

226129 build-depends: bytestring >= 0.10.4

227− if impl(ghc < 8.0)

228− build-depends: semigroups

229130

230131executable aeson-benchmark-compare-with-json

231− default-language: Haskell2010

232132 main-is: CompareWithJSON.hs

233133 ghc-options: -Wall -O2 -rtsopts

234134 build-depends:

@@ -243,7 +143,6 @@ executable aeson-benchmark-compare-with-json

243143 text

244144

245145executable aeson-benchmark-aeson-encode

246− default-language: Haskell2010

247146 main-is: AesonEncode.hs

248147 ghc-options: -Wall -O2 -rtsopts

249148 build-depends:

@@ -256,7 +155,6 @@ executable aeson-benchmark-aeson-encode

256155 time

257156

258157executable aeson-benchmark-aeson-parse

259− default-language: Haskell2010

260158 main-is: AesonParse.hs

261159 ghc-options: -Wall -O2 -rtsopts

262160 build-depends:

@@ -268,7 +166,6 @@ executable aeson-benchmark-aeson-parse

268166 time

269167

270168executable aeson-benchmark-json-parse

271− default-language: Haskell2010

272169 main-is: JsonParse.hs

273170 ghc-options: -Wall -O2 -rtsopts

274171 build-depends:

@@ -279,7 +176,6 @@ executable aeson-benchmark-json-parse

279176 time

280177

281178executable aeson-benchmark-dates

282− default-language: Haskell2010

283179 main-is: Dates.hs

284180 ghc-options: -Wall -O2 -rtsopts

285181 build-depends:

@@ -291,14 +187,12 @@ executable aeson-benchmark-dates

291187 aeson-benchmarks,

292188 text,

293189 time

294− if impl(ghc >= 8.2)

295− ghc-options: -Wno-simplifiable-class-constraints

296190

297191executable aeson-benchmark-map

298− default-language: Haskell2010

299192 main-is: AesonMap.hs

300193 ghc-options: -Wall -O2 -rtsopts

301194 build-depends:

195+ aeson,

302196 aeson-benchmarks,

303197 base,

304198 base-compat,

@@ -312,10 +206,10 @@ executable aeson-benchmark-map

312206 unordered-containers

313207

314208executable aeson-benchmark-foldable

315− default-language: Haskell2010

316209 main-is: AesonFoldable.hs

317210 ghc-options: -Wall -O2 -rtsopts

318211 build-depends:

212+ aeson,

319213 aeson-benchmarks,

320214 base,

321215 base-compat,

@@ -328,18 +222,3 @@ executable aeson-benchmark-foldable

328222 text,

329223 unordered-containers,

330224 vector

331−

332−executable aeson-issue-673

333− default-language: Haskell2010

334− main-is: Issue673.hs

335− ghc-options: -Wall -O1 -rtsopts

336− build-depends:

337− aeson-benchmarks,

338− attoparsec,

339− base,

340− bytestring,

341− scientific,

342− base-compat,

343− criterion >= 1.0

344− if impl(ghc < 8.0)

345− build-depends: semigroups

cabal.projectdeleted−5

@@ -1,5 +0,0 @@

1−with-compiler: ghc

2−packages: .

3−packages: attoparsec-iso8601

4−-- packages: benchmarks

5−tests: true

changelog.md+4−204

@@ -1,209 +1,6 @@

11For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md).

3−### upcoming

4−

5−* `FromJSON` instance of `Ratio a` now parses numbers in addtion to

6− standard `{numerator=..., denumerator=...}` encoding.

7−

8−### 1.4.6.0

9−

10−* Provide a clearer error message when a required tagKey for a constructor is missing, thanks to Guru Devanla.

11− The error message now looks like this: `Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found`

12−

13−* Add `formatPath` and `formatRelativePath` functions to turn a `JSONPath` into a `String`, thanks to Robbie McMichael

14−

15−

16−### 1.4.5.0

17−

18−* Expose `(<?>)`, `JSONPath` and `JSONPathElement(..)` from `Data.Aeson.Types`. Previously only available through internal modules. Thanks to Luke Clifton.

19−

20−* Support for base-compat 0.11, thanks to Ryan Scott.

21−

22−* Travis build for GHC 8.8, thanks to Oleg Grenrus.

23−

24−### 1.4.4.0

25−

26−**New features**:

27−

28−* Adds a parameterized parser `jsonWith` that can be used to choose how to handle duplicate keys in objects, thanks to Xia Li-Yao.

29−

30−* Add generic implementations of `FromJSONKey` and `ToJSONKey`, thanks to Xia Li-Yao. Example:

31−

32−```haskell

33−data Foo = Bar

34− deriving Generic

35−

36−opts :: JSONKeyOptions

37−opts = defaultJSONKeyOptions { keyModifier = toLower }

38−

39−instance ToJSONKey Foo where

40− toJSONKey = genericToJSONKey opts

41−

42−instance FromJSONKey Foo where

43− fromJSONKey = genericFromJSONKey opts

44−```

45−

46−**Minor**:

47−* aeson now uses `time-compat` instead of `time-locale-compat`, thanks to Oleg Grenrus.

48−* Prepare for `MonadFail` breakages in GHC 8.8, thanks to Oleg Grenrus.

49−* Require `bytestring >= 0.10.8.1` for newer GHCs to avoid build failures, thanks to Oleg Grenrus.

50−* Support `primitive 0.7.*`, thanks to Adam Bergmark.

51−* Allow `semigroups 0.19.*` and `hashable 1.3.*`, thanks to Oleg Grenrus.

52−* Fix a typo in the error message when parsing `NonEmpty`, thanks to Colin Woodbury.

53−* Document surprising behavior when using `omitNothingFields` with type variables, thanks to Xia Li-Yao.

54−

55−**Internal changes**:

56−* Code cleanup by Oleg Grenrus

57−* Fix dependencies of the benchmarks on older GHC's, thanks to Xia Li-Yao.

58−

59−### 1.4.3.0

60−* Improve error messages for FromJSON in existing instances and GHC Generic implementation. Thanks to Xia Li-Yao & Igor Pashev.

61−* Tweak error-reporting combinators and their documentation. Thanks to Xia Li-Yao.

62− * `typeMismatch` is now about comparing JSON types (i.e., the expected and actual names of the Value constructor).

63− * `withObject` and other `with*` combinators now also mention the JSON types they expect

64− * New `unexpected` and `prependFailure` combinators.

65−* Add `Contravariant` `ToJSONKeyFunction` instance. Thanks to Oleg Grenrus.

66−* Add `KeyValue` instance for `Object`. Thanks to Robert Hensing.

67−* Improve performance when parsing certain large numbers, thanks to Oleg Grenrus.

68−* Add `Data.Aeson.QQ.Simple` - A limited version of aeson-qq. Thanks to Oleg Grenrus.

69−* Exposes internal helper functions like `<?>`, `JSONPath`, and `parseIndexedJSON` from `Data.Aeson` module. Thanks to Abid Uzair.

70−* Better error messages when there are syntax errors parsing objects and arrays. Thanks to Fintan Halpenny.

71−* Support building with `th-abstraction-0.3.0.0` or later. Thanks to Ryan Scott.

72−

73−### 1.4.2.0

74−

75−* Add `Data.Aeson.QQ.Simple` which is a simpler version of the `aeson-qq` package, it does not support interpolation, thanks to Oleg Grenrus.

76−* Add `Contravariant ToJSONKeyFunction` instance, thanks to Oleg Grenrus.

77−* Add `KeyValue Object` instance, thanks to Robert Hensing

78−* Improved performance when parsing large numbers, thanks to Oleg Grenrus.

79−

80−### 1.4.1.0

81−

82−* Optimizations of generics, thanks to Rémy Oudompheng, here are some numbers for GHC 8.4:

83− * Compilation time: G/BigProduct.hs is 25% faster, G/BigRecord.hs is 2x faster.

84− * Runtime performance: BigRecord/toJSON/generic and BigProduct/encode/generic are more than 2x faster.

85−* Added To/FromJSON instances for `Void` and Generics's `V1`, thanks to Will Yager

86−* Added To/FromJSON instances for `primitive`'s `Array`, `SmallArray`, `PrimArray` and `UnliftedArray`, thanks to Andrew Thad.

87−* Fixes handling of `UTCTime` wrt. leap seconds , thanks to Adam Schønemann

88−* Warning and documentation fixes thanks to tom-bop, Gabor Greif, Ian Jeffries, and Mateusz Curyło.

89−

90−## 1.4.0.0

91−

92−This release introduces bounds on the size of `Scientific` numbers when they are converted to other arbitrary precision types that do not represent them efficiently in memory.

93−

94−This means that trying to decode a number such as `1e1000000000` into an `Integer` will now fail instead of using a lot of memory. If you need to represent large numbers you can add a newtype (preferably over `Scientific`) and providing a parser using `withScientific`.

95−

96−The following instances are affected by this:

97−* `FromJSON Natural`

98−* `FromJSONKey Natural`

99−* `FromJSON Integer`

100−* `FromJSONKey Integer`

101−* `FromJSON NominalDiffTime`

102−

103−For the same reasons the following instances & functions have been removed:

104−* Remove `FromJSON Data.Attoparsec.Number` instance. Note that `Data.Attoparsec.Number` is deprecated.

105−* Remove deprecated `withNumber`, use `withScientific` instead.

106−

107−Finally, encoding integral values with large exponents now uses scientific notation, this saves space for large numbers.

108−

109−#### 1.3.1.1

110−

111−* Catch 0 denominators when parsing Ratio

112−

113−### 1.3.1.0

114−

115−* Fix bug in generically derived `FromJSON` instances that are using `unwrapUnaryRecords`, thanks to Xia Li-yao

116−* Allow base-compat 0.10.*, thanks to Oleg Grenrus

117−

118−## 1.3.0.0

119−

120−Breaking changes:

121−* `GKeyValue` has been renamed to `KeyValuePair`, thanks to Xia Li-yao

122−* Removed unused `FromJSON` constraint in `withEmbeddedJson`, thanks to Tristan Seligmann

123−

124−Other improvements:

125−* Optimizations of TH toEncoding, thanks to Xia Li-yao

126−* Optimizations of hex decoding when using the default/pure unescape implementation, thanks to Xia Li-yao

127−* Improved error message on `Day` parse failures, thanks to Gershom Bazerman

128−* Add `encodeFile` as well as `decodeFile*` variants, thanks to Markus Hauck

129−* Documentation fixes, thanks to Lennart Spitzner

130−* CPP cleanup, thanks to Ryan Scott

131−

132−### 1.2.4.0

133−

134−* Add `Ord` instance for `JSONPathElement`, thanks to Simon Hengel.

135−

136−

137−### 1.2.3.0

138−

139−* Added `withEmbeddedJSON` to help parse JSON embedded inside a JSON string, thanks to Jesse Kempf.

140−* Memory usage improvements to the default (pure) parser, thanks to Jonathan Paugh. Also thanks to Neil Mitchell & Oleg Grenrus for contributing a benchmark.

141−* `omitNothingFields` now works for the `Option` newtype, thanks to Xia Li-yao.

142−* Some documentation fixes, thanks to Jonathan Paug & Philippe Crama.

143−

144−### 1.2.2.0

145−

146−* Add `FromJSON` and `ToJSON` instances for

147− * `DiffTime`, thanks to Víctor López Juan.

148− * `CTime`, thanks to Daniel Díaz.

149−* Fix handling of fractions when parsing Natural, thanks to Yuriy Syrovetskiy.

150−* Change text in error messages for Integral types to make them follow the common pattern, thanks to Yuriy Syrovetskiy.

151−* Add missing `INCOHERENT` pragma for `RecordToPair`, thanks to Xia Li-yao.

152−* Everything related to `Options` is now exported from `Data.Aeson`, thanks to Xia Li-yao.

153−* Optimizations to not escape text in clear cases, thanks to Oleg Grenrus.

154−* Some documentation fixes, thanks to Phil de Joux & Xia Li-yao.

155−

156−### 1.2.1.0

157−

158−* Add `parserThrowError` and `parserCatchError` combinators, thanks to Oleg Grenrus.

159−

160−* Add `Generic` instance for `Value`, thanks to Xia Li-yao.

161−

162−* Fix a mistake in the 1.2.0.0 changelog, the `cffi` flag is disabled by default! Thanks to dbaynard.

163−

164−## 1.2.0.0

165−

166−* `tagSingleConstructors`, an option to encode single-constructor types as tagged sums was added to `Options`. It is disabled by default for backward compatibility.

167−

168−* The `cffi` flag is now turned off (`False`) by default, this means C FFI code is no longer used by default. You can flip the flag to get C implementation.

169−

170−* The `Options` constructor is no longer exposed to prevent new options from being breaking changes, use `defaultOptions` instead.

171−

172−* The contents of `GToJSON` and `GToEncoding` are no longer exposed.

173−

174−* Some INLINE pragmas were removed to avoid GHC running out of simplifier ticks.

175−

176−### 1.1.2.0

177−

178−* Fix an accidental change in the format of `deriveJSON`. Thanks to Xia Li-yao!

179−

180−* Documentation improvements regarding `ToJSON`, `FromJSON`, and `SumEncoding`. Thanks to Xia Li-yao and Lennart Spitzner!

181−

182−### 1.1.1.0

183−

184−* Added a pure implementation of the C FFI code, the C FFI code. If you wish to use the pure haskell version set the `cffi` flag to `False`. This should make aeson compile when C isn't available, such as for GHCJS. Thanks to James Parker & Marcin Tolysz!

185−

186−* Using the `fast` flag can no longer cause a test case to fail. As far as we know this didn't affect any users of the library itself. Thanks to Xia Li-yao!

187−

188−## 1.1.0.0

189−

190−* Added instances for `UUID`.

191−

192−* The operators for parsing fields now have named aliases:

193− - `.:` => `parseField`

194− - `.:?` => `parseFieldMaybe`

195− - `.:!` => `parseFieldMaybe'`

196− - These functions now also have variants with explicit parser functions: `explicitParseField`, `explicitParseFieldMaybe`, "explicitParseFieldMaybe'`

197−Thanks to Oleg Grenrus.

198−

199−* `ToJSONKey (Identity a)` and `FromJSONKey (Identity a)` no longer require the unnecessary `FromJSON a` constraint. Thanks to Oleg Grenrus.

200−

201−* Added `Data.Aeson.Encoding.pair'` which is a more general version of `Data.Aeson.Encoding.pair`. Thanks to Andrew Martin.

202−

203−* `Day`s BCE are properly encoded and `+` is now a valid prefix for `Day`s CE. Thanks to Matt Parsons.

204−

205−* Some commonly used ToJSON instances are now specialized in order to improve compile time. Thanks to Bartosz Nitka.

206−

3+#### WIP

2074

2085[JSONTestSuite](https://github.com/nst/JSONTestSuite) cleanups, all

2096motivated by tighter RFC 7159 compliance:

@@ -225,10 +22,13 @@ categorised as follows:

22522

22623* The parser does not (and will not) support UTF-16, UTF-32, or byte

22724 order marks (BOM).

25+

22826* The parser accepts unescaped control characters, even though the RFC

22927 states that control characters must be escaped. (This may change at

23028 some point, but doesn't seem important.)

23129

30+- Days BCE are properly encoded.

31+

23232#### 1.0.2.1

23333

23434* Fixes a regression where a bunch of valid characters caused an

examples/Generic.hs+1−1

@@ -6,11 +6,11 @@

66-- automatically derive the Generic class for us.

88{-# LANGUAGE DeriveGeneric #-}

9−{-# LANGUAGE NoImplicitPrelude #-}

109{-# LANGUAGE OverloadedStrings #-}

1110

1211module Main (main) where

1312

13+import Prelude ()

1414import Prelude.Compat

1515

1616import Data.Aeson (FromJSON, ToJSON, decode, encode)

examples/Simplest.hs+1−1

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21{-# LANGUAGE OverloadedStrings #-}

32{-# LANGUAGE RecordWildCards #-}

54module Main (main) where

6+import Prelude ()

77import Prelude.Compat

99import Control.Applicative (empty)

examples/TemplateHaskell.hs+1−1

@@ -1,12 +1,12 @@

11-- We can use Template Haskell (TH) to generate instances of the

22-- FromJSON and ToJSON classes automatically. This is the fastest way

33-- to add JSON support for a type.

4−{-# LANGUAGE NoImplicitPrelude #-}

54{-# LANGUAGE OverloadedStrings #-}

65{-# LANGUAGE TemplateHaskell #-}

87module Main (main) where

9+import Prelude ()

1010import Prelude.Compat

1111

1212import Data.Aeson (decode, encode)

examples/Twitter.hs+2−4

@@ -10,7 +10,6 @@

1010

1111{-# LANGUAGE DeriveDataTypeable #-}

1212{-# LANGUAGE DeriveGeneric #-}

13−{-# LANGUAGE NoImplicitPrelude #-}

1413

1514module Twitter

1615 (

@@ -20,6 +19,7 @@ module Twitter

2019 , Result(..)

2120 ) where

2221

22+import Prelude ()

2323import Prelude.Compat

2424

2525import Control.DeepSeq

@@ -27,9 +27,7 @@ import Data.Data (Typeable, Data)

2727import Data.Int (Int64)

2828import Data.Text (Text)

2929import GHC.Generics (Generic)

30−

31−{-# ANN module "Hlint: ignore Use camelCase" #-}

32−{-# ANN module "Hlint: ignore Use newtype instead of data" #-}

30+import Prelude hiding (id)

3331

3432data Metadata = Metadata {

3533 result_type :: Text

examples/Twitter/Generic.hs+37−31

@@ -1,7 +1,6 @@

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

2−

3−{-# LANGUAGE NoImplicitPrelude #-}

4−

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE PackageImports #-}

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

76module Twitter.Generic

@@ -12,33 +11,40 @@ module Twitter.Generic

1211 , Result(..)

1312 ) where

1413

15−import Prelude.Compat ()

14+import Prelude ()

15+import Prelude.Compat

1616

1717import Twitter

18−import Twitter.Options

19−

20−import Data.Aeson (ToJSON (..), FromJSON (..), genericToJSON, genericToEncoding, genericParseJSON)

21−

22−instance ToJSON Metadata where

23− toJSON = genericToJSON twitterOptions

24− toEncoding = genericToEncoding twitterOptions

25−instance FromJSON Metadata where

26− parseJSON = genericParseJSON twitterOptions

27−

28−instance ToJSON Geo where

29− toJSON = genericToJSON twitterOptions

30− toEncoding = genericToEncoding twitterOptions

31−instance FromJSON Geo where

32− parseJSON = genericParseJSON twitterOptions

33−

34−instance ToJSON Story where

35− toJSON = genericToJSON twitterOptions

36− toEncoding = genericToEncoding twitterOptions

37−instance FromJSON Story where

38− parseJSON = genericParseJSON twitterOptions

39−

40−instance ToJSON Result where

41− toJSON = genericToJSON twitterOptions

42− toEncoding = genericToEncoding twitterOptions

43−instance FromJSON Result where

44− parseJSON = genericParseJSON twitterOptions

18+

19+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

20+import Data.Aeson (ToJSON, FromJSON)

21+#else

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

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

24+#endif

25+

26+instance ToJSON Metadata

27+instance FromJSON Metadata

28+

29+instance ToJSON Geo

30+instance FromJSON Geo

31+

32+instance ToJSON Story

33+instance FromJSON Story

34+

35+instance ToJSON Result

36+instance FromJSON Result

37+

38+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

39+instance B.ToJSON Metadata

40+instance B.FromJSON Metadata

41+

42+instance B.ToJSON Geo

43+instance B.FromJSON Geo

44+

45+instance B.ToJSON Story

46+instance B.FromJSON Story

47+

48+instance B.ToJSON Result

49+instance B.FromJSON Result

50+#endif

examples/Twitter/Manual.hs+136−3

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

11-- Manually write instances.

2−{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE PackageImports #-}

35{-# LANGUAGE OverloadedStrings #-}

46{-# LANGUAGE RecordWildCards #-}

5−

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

89module Twitter.Manual

@@ -13,13 +14,20 @@ module Twitter.Manual

1314 , Result(..)

1415 ) where

1516

17+import Prelude ()

1618import Prelude.Compat

1719

1820import Control.Applicative

19−import Data.Semigroup ((<>))

21+import Data.Monoid ((<>))

22+import Prelude hiding (id)

2023import Twitter

2124

25+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

2226import Data.Aeson hiding (Result)

27+#else

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

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

30+#endif

2331

2432instance ToJSON Metadata where

2533

@@ -144,3 +152,128 @@ instance FromJSON Result where

144152 <*> v .: "max_id_str"

145153 <*> v .: "query"

146154 parseJSON _ = empty

155+

156+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

157+instance B.ToJSON Metadata where

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

159+ "result_type" B..= result_type

160+ ]

161+

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

163+ "result_type" B..= result_type

164+

165+instance B.FromJSON Metadata where

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

167+ parseJSON _ = empty

168+

169+instance B.ToJSON Geo where

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

171+ "type_" B..= type_

172+ , "coordinates" B..= coordinates

173+ ]

174+

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

176+ "type_" B..= type_

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

178+

179+instance B.FromJSON Geo where

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

181+ v B..: "type_"

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

183+ parseJSON _ = empty

184+

185+instance B.ToJSON Story where

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

187+ "from_user_id_str" B..= from_user_id_str

188+ , "profile_image_url" B..= profile_image_url

189+ , "created_at" B..= created_at

190+ , "from_user" B..= from_user

191+ , "id_str" B..= id_str

192+ , "metadata" B..= metadata

193+ , "to_user_id" B..= to_user_id

194+ , "text" B..= text

195+ , "id" B..= id_

196+ , "from_user_id" B..= from_user_id

197+ , "geo" B..= geo

198+ , "iso_language_code" B..= iso_language_code

199+ , "to_user_id_str" B..= to_user_id_str

200+ , "source" B..= source

201+ ]

202+

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

204+ "from_user_id_str" B..= from_user_id_str

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

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

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

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

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

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

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

212+ <> "id" B..= id_

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

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

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

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

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

218+

219+instance B.FromJSON Story where

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

221+ v B..: "from_user_id_str"

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

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

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

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

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

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

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

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

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

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

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

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

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

235+ parseJSON _ = empty

236+

237+instance B.ToJSON Result where

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

239+ "results" B..= results

240+ , "max_id" B..= max_id

241+ , "since_id" B..= since_id

242+ , "refresh_url" B..= refresh_url

243+ , "next_page" B..= next_page

244+ , "results_per_page" B..= results_per_page

245+ , "page" B..= page

246+ , "completed_in" B..= completed_in

247+ , "since_id_str" B..= since_id_str

248+ , "max_id_str" B..= max_id_str

249+ , "query" B..= query

250+ ]

251+

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

253+ "results" B..= results

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

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

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

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

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

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

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

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

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

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

264+

265+instance B.FromJSON Result where

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

267+ v B..: "results"

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

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

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

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

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

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

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

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

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

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

278+ parseJSON _ = empty

279+#endif

examples/Twitter/Options.hsdeleted−10

@@ -1,10 +0,0 @@

1−module Twitter.Options (module Twitter.Options) where

2−

3−import Data.Aeson

4−

5−twitterOptions :: Options

6−twitterOptions = defaultOptions

7− { fieldLabelModifier = \x -> case x of

8− "id_" -> "id"

9− _ -> x

10− }

examples/Twitter/TH.hs+19−7

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

11-- Use Template Haskell to generate good instances.

3−{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE PackageImports #-}

45{-# LANGUAGE TemplateHaskell #-}

5−

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

88module Twitter.TH

@@ -13,13 +13,25 @@ module Twitter.TH

1313 , Result(..)

1414 ) where

1515

16+import Prelude ()

1617

1718import Twitter

18−import Twitter.Options

1919

20+#ifndef HAS_BOTH_AESON_AND_BENCHMARKS

2021import Data.Aeson.TH

22+#else

23+import "aeson" Data.Aeson.TH

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

25+#endif

26+

27+$(deriveJSON defaultOptions ''Metadata)

28+$(deriveJSON defaultOptions ''Geo)

29+$(deriveJSON defaultOptions ''Story)

30+$(deriveJSON defaultOptions ''Result)

2131

22−$(deriveJSON twitterOptions ''Metadata)

23−$(deriveJSON twitterOptions ''Geo)

24−$(deriveJSON twitterOptions ''Story)

25−$(deriveJSON twitterOptions ''Result)

32+#ifdef HAS_BOTH_AESON_AND_BENCHMARKS

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

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

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

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

37+#endif

ffi/Data/Aeson/Parser/UnescapeFFI.hsdeleted−52

@@ -1,52 +0,0 @@

1−{-# LANGUAGE ForeignFunctionInterface #-}

2−{-# LANGUAGE MagicHash #-}

3−{-# LANGUAGE UnliftedFFITypes #-}

4−

5−module Data.Aeson.Parser.UnescapeFFI

6− (

7− unescapeText

8− ) where

9−

10−import Control.Exception (evaluate, throw, try)

11−import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)

12−import Data.ByteString as B

13−import Data.ByteString.Internal as B

14−import Data.Text.Encoding.Error (UnicodeException (..))

15−import Data.Text.Internal (Text (..))

16−import Data.Text.Internal.Private (runText)

17−import Data.Text.Unsafe (unsafeDupablePerformIO)

18−import Data.Word (Word8)

19−import Foreign.C.Types (CInt (..), CSize (..))

20−import Foreign.ForeignPtr (withForeignPtr)

21−import Foreign.Marshal.Utils (with)

22−import Foreign.Ptr (Ptr, plusPtr)

23−import Foreign.Storable (peek)

24−import GHC.Base (MutableByteArray#)

25−import qualified Data.Text.Array as A

26−

27−foreign import ccall unsafe "_js_decode_string" c_js_decode

28− :: MutableByteArray# s -> Ptr CSize

29− -> Ptr Word8 -> Ptr Word8 -> IO CInt

30−

31−unescapeText' :: ByteString -> Text

32−unescapeText' (PS fp off len) = runText $ \done -> do

33− let go dest = withForeignPtr fp $ \ptr ->

34− with (0::CSize) $ \destOffPtr -> do

35− let end = ptr `plusPtr` (off + len)

36− loop curPtr = do

37− res <- c_js_decode (A.maBA dest) destOffPtr curPtr end

38− case res of

39− 0 -> do

40− n <- peek destOffPtr

41− unsafeSTToIO (done dest (fromIntegral n))

42− _ ->

43− throw (DecodeError desc Nothing)

44− loop (ptr `plusPtr` off)

45− (unsafeIOToST . go) =<< A.new len

46− where

47− desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"

48−{-# INLINE unescapeText' #-}

49−

50−unescapeText :: ByteString -> Either UnicodeException Text

51−unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'

52−{-# INLINE unescapeText #-}

pure/Data/Aeson/Parser/UnescapePure.hsdeleted−254

@@ -1,254 +0,0 @@

1−-- WARNING: This file is security sensitive as it uses unsafeWrite which does

2−-- not check bounds. Any changes should be made with care and we would love to

3−-- get informed about them, just cc us in any PR targetting this file: @eskimor @jprider63

4−-- We would be happy to review the changes!

5−

6−-- The security check at the end (pos > length) only works if pos grows

7−-- monotonously, if this condition does not hold, the check is flawed.

8−module Data.Aeson.Parser.UnescapePure

9− (

10− unescapeText

11− ) where

12−

13−import Control.Exception (evaluate, throw, try)

14−import Control.Monad (when)

15−import Data.ByteString as B

16−import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))

17−import Data.Text (Text)

18−import qualified Data.Text.Array as A

19−import Data.Text.Encoding.Error (UnicodeException (..))

20−import Data.Text.Internal.Private (runText)

21−import Data.Text.Unsafe (unsafeDupablePerformIO)

22−import Data.Word (Word8, Word16, Word32)

23−import GHC.ST (ST)

24−

25−-- Different UTF states.

26−data Utf =

27− UtfGround

28− | UtfTail1

29− | UtfU32e0

30− | UtfTail2

31− | UtfU32ed

32− | Utf843f0

33− | UtfTail3

34− | Utf843f4

35− deriving (Eq)

36−

37−data State =

38− StateNone

39− | StateUtf !Utf !Word32

40− | StateBackslash

41− | StateU0

42− | StateU1 !Word16

43− | StateU2 !Word16

44− | StateU3 !Word16

45− | StateS0

46− | StateS1

47− | StateSU0

48− | StateSU1 !Word16

49− | StateSU2 !Word16

50− | StateSU3 !Word16

51− deriving (Eq)

52−

53−-- References:

54−-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/

55−-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in

56−

57−setByte1 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

58−setByte1 point word = point .|. fromIntegral (word .&. 0x3f)

59−{-# INLINE setByte1 #-}

60−

61−setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

62−setByte2 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 6)

63−{-# INLINE setByte2 #-}

64−

65−setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

66−setByte2Top point word = point .|. (fromIntegral (word .&. 0x1f) `shiftL` 6)

67−{-# INLINE setByte2Top #-}

68−

69−setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

70−setByte3 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 12)

71−{-# INLINE setByte3 #-}

72−

73−setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

74−setByte3Top point word = point .|. (fromIntegral (word .&. 0xf) `shiftL` 12)

75−{-# INLINE setByte3Top #-}

76−

77−setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a

78−setByte4 point word = point .|. (fromIntegral (word .&. 0x7) `shiftL` 18)

79−{-# INLINE setByte4 #-}

80−

81−decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)

82−decode UtfGround point word = case word of

83− w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)

84− w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)

85− 0xe0 -> (UtfU32e0, setByte3Top point word)

86− w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)

87− 0xed -> (UtfU32ed, setByte3Top point word)

88− w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)

89− 0xf0 -> (Utf843f0, setByte4 point word)

90− w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)

91− 0xf4 -> (Utf843f4, setByte4 point word)

92− _ -> throwDecodeError

93−

94−decode UtfU32e0 point word = case word of

95− w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)

96− _ -> throwDecodeError

97−

98−decode UtfU32ed point word = case word of

99− w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)

100− _ -> throwDecodeError

101−

102−decode Utf843f0 point word = case word of

103− w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)

104− _ -> throwDecodeError

105−

106−decode Utf843f4 point word = case word of

107− w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)

108− _ -> throwDecodeError

109−

110−decode UtfTail3 point word = case word of

111− w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)

112− _ -> throwDecodeError

113−

114−decode UtfTail2 point word = case word of

115− w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)

116− _ -> throwDecodeError

117−

118−decode UtfTail1 point word = case word of

119− w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)

120− _ -> throwDecodeError

121−

122−decodeHex :: Word8 -> Word16

123−decodeHex x

124− | 48 <= x && x <= 57 = fromIntegral x - 48 -- 0-9

125− | 65 <= x && x <= 70 = fromIntegral x - 55 -- A-F

126− | 97 <= x && x <= 102 = fromIntegral x - 87 -- a-f

127− | otherwise = throwDecodeError

128−

129−unescapeText' :: ByteString -> Text

130−unescapeText' bs = runText $ \done -> do

131− dest <- A.new len

132−

133− (pos, finalState) <- loop dest (0, StateNone) 0

134−

135− -- Check final state. Currently pos gets only increased over time, so this check should catch overflows.

136− when ( finalState /= StateNone || pos > len)

137− throwDecodeError

138−

139− done dest pos -- TODO: pos, pos-1??? XXX

140−

141− where

142− len = B.length bs

143−

144− runUtf dest pos st point c = case decode st point c of

145− (UtfGround, 92) -> -- Backslash

146− return (pos, StateBackslash)

147− (UtfGround, w) | w <= 0xffff ->

148− writeAndReturn dest pos (fromIntegral w) StateNone

149− (UtfGround, w) -> do

150− write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))

151− writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone

152− (st', p) ->

153− return (pos, StateUtf st' p)

154−

155− loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State)

156− loop _ ps i | i >= len = return ps

157− loop dest ps i = do

158− let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell.

159− ps' <- f dest ps c

160− loop dest ps' $ i+1

161−

162− -- No pending state.

163− f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c

164−

165− -- In the middle of parsing a UTF string.

166− f dest (pos, StateUtf st point) c = runUtf dest pos st point c

167−

168− -- In the middle of escaping a backslash.

169− f dest (pos, StateBackslash) 34 = writeAndReturn dest pos 34 StateNone -- "

170− f dest (pos, StateBackslash) 92 = writeAndReturn dest pos 92 StateNone -- Backslash

171− f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- /

172− f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b

173− f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f

174− f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n

175− f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r

176− f dest (pos, StateBackslash) 116 = writeAndReturn dest pos 9 StateNone -- t

177− f _ (pos, StateBackslash) 117 = return (pos, StateU0) -- u

178− f _ ( _, StateBackslash) _ = throwDecodeError

179−

180− -- Processing '\u'.

181− f _ (pos, StateU0) c =

182− let w = decodeHex c in

183− return (pos, StateU1 (w `shiftL` 12))

184−

185− f _ (pos, StateU1 w') c =

186− let w = decodeHex c in

187− return (pos, StateU2 (w' .|. (w `shiftL` 8)))

188−

189− f _ (pos, StateU2 w') c =

190− let w = decodeHex c in

191− return (pos, StateU3 (w' .|. (w `shiftL` 4)))

192−

193− f dest (pos, StateU3 w') c =

194− let w = decodeHex c in

195− let u = w' .|. w in

196−

197− -- Get next state based on surrogates.

198− let st

199− | u >= 0xd800 && u <= 0xdbff = -- High surrogate.

200− StateS0

201− | u >= 0xdc00 && u <= 0xdfff = -- Low surrogate.

202− throwDecodeError

203− | otherwise =

204− StateNone

205− in

206− writeAndReturn dest pos u st

207−

208− -- Handle surrogates.

209− f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash

210− f _ ( _, StateS0) _ = throwDecodeError

211−

212− f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u

213− f _ ( _, StateS1) _ = throwDecodeError

214−

215− f _ (pos, StateSU0) c =

216− let w = decodeHex c in

217− return (pos, StateSU1 (w `shiftL` 12))

218−

219− f _ (pos, StateSU1 w') c =

220− let w = decodeHex c in

221− return (pos, StateSU2 (w' .|. (w `shiftL` 8)))

222−

223− f _ (pos, StateSU2 w') c =

224− let w = decodeHex c in

225− return (pos, StateSU3 (w' .|. (w `shiftL` 4)))

226−

227− f dest (pos, StateSU3 w') c =

228− let w = decodeHex c in

229− let u = w' .|. w in

230−

231− -- Check if not low surrogate.

232− if u < 0xdc00 || u > 0xdfff then

233− throwDecodeError

234− else

235− writeAndReturn dest pos u StateNone

236−

237−write :: A.MArray s -> Int -> Word16 -> ST s ()

238−write dest pos char =

239− A.unsafeWrite dest pos char

240−{-# INLINE write #-}

241−

242−writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)

243−writeAndReturn dest pos char res = do

244− write dest pos char

245− return (pos + 1, res)

246−{-# INLINE writeAndReturn #-}

247−

248−throwDecodeError :: a

249−throwDecodeError =

250− let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in

251− throw (DecodeError desc Nothing)

252−

253−unescapeText :: ByteString -> Either UnicodeException Text

254−unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'

run-hlint.shdeleted−7

@@ -1,7 +0,0 @@

1−#!/bin/bash

2−

3−if hash hlint 2>/dev/null; then

4− hlint "$@"

5−else

6− ./hlint.sh "$@"

7−fi

stack-bench.yaml+6−10

@@ -1,12 +1,8 @@

1−resolver: nightly-2019-09-21

2−# We use aeson in the snapshot to

3−# - avoid recompilation of criterion

4−# - compare against it

5−# - '.'

6−#

7−# Also we use separate working directory to avoid "unregistering aeson"

8−# caused recompilations

9−work-dir: .stack-work-bench

1+resolver: lts-6.5

102packages:

113- benchmarks

12−extra-deps: []

4+extra-deps:

5+- semigroups-0.18.2

6+flags:

7+ semigroups:

8+ bytestring-builder: false

stack-ffi-unescape.yamldeleted−9

@@ -1,9 +0,0 @@

1−resolver: nightly-2019-09-21

2−packages:

3−- '.'

4−flags:

5− aeson:

6− fast: true

7− cffi: true

8−extra-deps:

9−- Diff-0.4.0

stack-lts12.yamldeleted−15

@@ -1,15 +0,0 @@

1−resolver: lts-12.26

2−packages:

3−- '.'

4−- attoparsec-iso8601

5−flags:

6− aeson:

7− fast: true

8− cffi: true

9−extra-deps:

10−- base-orphans-0.8.1

11−- hashable-time-0.2.0.1

12−- QuickCheck-2.13.1

13−- quickcheck-instances-0.3.21

14−- splitmix-0.0.2

15−- time-compat-1.9.2.2

stack-lts6.yamlnew file+10

@@ -0,0 +1,10 @@

1+resolver: lts-6.17

2+packages:

3+- '.'

4+extra-deps:

5+- semigroups-0.18.2

6+flags:

7+ aeson:

8+ fast: true

9+ semigroups:

10+ bytestring-builder: false

stack-lts7.yamlnew file+6

@@ -0,0 +1,6 @@

1+resolver: lts-7.0

2+packages:

3+- '.'

4+flags:

5+ aeson:

6+ fast: true

stack-nightly.yaml+1−6

@@ -1,11 +1,6 @@

1−resolver: nightly-2019-10-14

1+resolver: nightly-2016-09-15

22packages:

33- '.'

4−- attoparsec-iso8601

54flags:

65 aeson:

76 fast: true

8− attoparsec-iso8601:

9− fast: true

10−extra-deps:

11−- generic-deriving-1.12.4

tests/DataFamilies/Encoders.hs+2−2

@@ -1,10 +1,10 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

43{-# LANGUAGE TemplateHaskell #-}

6−module DataFamilies.Encoders (module DataFamilies.Encoders) where

5+module DataFamilies.Encoders where

7+import Prelude ()

88import Prelude.Compat

1010import Data.Aeson.TH

tests/DataFamilies/Instances.hs+1−2

@@ -1,13 +1,12 @@

11{-# LANGUAGE FlexibleInstances #-}

22{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

43{-# LANGUAGE TemplateHaskell #-}

54{-# LANGUAGE TypeFamilies #-}

6−

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

97module DataFamilies.Instances () where

108

9+import Prelude ()

1110import Prelude.Compat

1211

1312import Data.Aeson.TH

tests/DataFamilies/Properties.hs+5−6

@@ -1,21 +1,20 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

43module DataFamilies.Properties (tests) where

5+import Prelude ()

66import Prelude.Compat

88import DataFamilies.Encoders

99import DataFamilies.Instances ()

10−import PropUtils

10+import Properties hiding (tests)

1111

12−

13−import Test.Tasty (TestTree, testGroup)

14−import Test.Tasty.QuickCheck (testProperty)

12+import Test.Framework (Test, testGroup)

13+import Test.Framework.Providers.QuickCheck2 (testProperty)

1514

1615--------------------------------------------------------------------------------

1716

18−tests :: TestTree

17+tests :: Test

1918tests = testGroup "data families" [

2019 testGroup "template-haskell" [

2120 testGroup "toJSON" [

tests/DataFamilies/Types.hs+2−2

@@ -4,13 +4,13 @@

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GADTs #-}

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE NoImplicitPrelude #-}

87{-# LANGUAGE StandaloneDeriving #-}

98{-# LANGUAGE TemplateHaskell #-}

109{-# LANGUAGE TypeFamilies #-}

1110

12−module DataFamilies.Types (module DataFamilies.Types) where

11+module DataFamilies.Types where

1312

13+import Prelude ()

1414import Prelude.Compat

1515

1616import Generics.Deriving.TH (deriveAll0)

tests/Encoders.hs+8−123

@@ -1,12 +1,11 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

43{-# LANGUAGE TemplateHaskell #-}

6−module Encoders (module Encoders) where

5+module Encoders where

7+import Prelude ()

88import Prelude.Compat

9−import Data.Text (Text)

109

1110import Data.Aeson.TH

1211import Data.Aeson.Types

@@ -97,18 +96,6 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle

9796gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary

9897gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

9998

100−keyOptions :: JSONKeyOptions

101−keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) }

102−

103−gNullaryToJSONKey :: Nullary -> Either String Text

104−gNullaryToJSONKey x = case genericToJSONKey keyOptions of

105− ToJSONKeyText p _ -> Right (p x)

106− _ -> Left "Should be a ToJSONKeyText"

107−

108−gNullaryFromJSONKey :: Text -> Parser Nullary

109−gNullaryFromJSONKey t = case genericFromJSONKey keyOptions of

110− FromJSONKeyTextParser p -> p t

111− _ -> fail "Not a TextParser"

11299

113100--------------------------------------------------------------------------------

114101-- SomeType encoders/decoders

@@ -188,6 +175,7 @@ gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray

188175gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)

189176gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray

190177

178+#if __GLASGOW_HASKELL__ >= 706

191179gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a

192180gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray

193181

@@ -196,6 +184,7 @@ gSomeTypeLiftToJSON2ElemArray = genericLiftToJSON opts2ElemArray

196184

197185gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a

198186gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray

187+#endif

199188

200189

201190gSomeTypeToJSONTaggedObject :: SomeType Int -> Value

@@ -207,6 +196,7 @@ gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject

207196gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)

208197gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject

209198

199+#if __GLASGOW_HASKELL__ >= 706

210200gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a

211201gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject

212202

@@ -215,6 +205,7 @@ gSomeTypeLiftToJSONTaggedObject = genericLiftToJSON optsTaggedObject

215205

216206gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a

217207gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject

208+#endif

218209

219210

220211gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value

@@ -226,6 +217,7 @@ gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingl

226217gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)

227218gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

228219

220+#if __GLASGOW_HASKELL__ >= 706

229221gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a

230222gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField

231223

@@ -234,6 +226,7 @@ gSomeTypeLiftToJSONObjectWithSingleField = genericLiftToJSON optsObjectWithSingl

234226

235227gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a

236228gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField

229+#endif

237230

238231

239232gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value

@@ -242,58 +235,6 @@ gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields

242235gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding

243236gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

244237

245−

246−thSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

247−thSomeTypeParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''SomeType)

248−

249−gSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

250−gSomeTypeParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

251−

252−

253−--------------------------------------------------------------------------------

254−-- Foo decoders

255−--------------------------------------------------------------------------------

256−

257−thFooParseJSONRejectUnknownFields :: Value -> Parser Foo

258−thFooParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''Foo)

259−

260−gFooParseJSONRejectUnknownFields :: Value -> Parser Foo

261−gFooParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

262−

263−

264−thFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

265−thFooParseJSONRejectUnknownFieldsTagged = $(mkParseJSON optsRejectUnknownFieldsTagged ''Foo)

266−

267−gFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

268−gFooParseJSONRejectUnknownFieldsTagged = genericParseJSON optsRejectUnknownFieldsTagged

269−

270−

271−--------------------------------------------------------------------------------

272−-- Option fields

273−--------------------------------------------------------------------------------

274−

275−thOptionFieldToJSON :: OptionField -> Value

276−thOptionFieldToJSON = $(mkToJSON optsOptionField 'OptionField)

277−

278−thOptionFieldToEncoding :: OptionField -> Encoding

279−thOptionFieldToEncoding = $(mkToEncoding optsOptionField 'OptionField)

280−

281−thOptionFieldParseJSON :: Value -> Parser OptionField

282−thOptionFieldParseJSON = $(mkParseJSON optsOptionField 'OptionField)

283−

284−gOptionFieldToJSON :: OptionField -> Value

285−gOptionFieldToJSON = genericToJSON optsOptionField

286−

287−gOptionFieldToEncoding :: OptionField -> Encoding

288−gOptionFieldToEncoding = genericToEncoding optsOptionField

289−

290−gOptionFieldParseJSON :: Value -> Parser OptionField

291−gOptionFieldParseJSON = genericParseJSON optsOptionField

292−

293−thMaybeFieldToJSON :: MaybeField -> Value

294−thMaybeFieldToJSON = $(mkToJSON optsOptionField 'MaybeField)

295−

296−

297238--------------------------------------------------------------------------------

298239-- IncoherentInstancesNeeded

299240--------------------------------------------------------------------------------

@@ -311,11 +252,6 @@ incoherentInstancesNeededParseJSONString :: FromJSON a => Value -> Parser (Incoh

311252incoherentInstancesNeededParseJSONString = case () of

312253 _ | True -> $(mkParseJSON defaultOptions ''IncoherentInstancesNeeded)

313254 | False -> genericParseJSON defaultOptions

314−

315−incoherentInstancesNeededToJSON :: ToJSON a => IncoherentInstancesNeeded a -> Value

316−incoherentInstancesNeededToJSON = case () of

317− _ | True -> $(mkToJSON defaultOptions ''IncoherentInstancesNeeded)

318− | False -> genericToJSON defaultOptions

319255#endif

320256

321257-------------------------------------------------------------------------------

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

405341

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

407343thGADTParseJSONDefault = $(mkParseJSON defaultOptions ''GADT)

408−

409−--------------------------------------------------------------------------------

410−-- OneConstructor encoders/decoders

411−--------------------------------------------------------------------------------

412−

413−thOneConstructorToJSONDefault :: OneConstructor -> Value

414−thOneConstructorToJSONDefault = $(mkToJSON defaultOptions ''OneConstructor)

415−

416−thOneConstructorToEncodingDefault :: OneConstructor -> Encoding

417−thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstructor)

418−

419−thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor

420−thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)

421−

422−thOneConstructorToJSONTagged :: OneConstructor -> Value

423−thOneConstructorToJSONTagged = $(mkToJSON optsTagSingleConstructors ''OneConstructor)

424−

425−thOneConstructorToEncodingTagged :: OneConstructor -> Encoding

426−thOneConstructorToEncodingTagged = $(mkToEncoding optsTagSingleConstructors ''OneConstructor)

427−

428−thOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

429−thOneConstructorParseJSONTagged = $(mkParseJSON optsTagSingleConstructors ''OneConstructor)

430−

431−

432−gOneConstructorToJSONDefault :: OneConstructor -> Value

433−gOneConstructorToJSONDefault = genericToJSON defaultOptions

434−

435−gOneConstructorToEncodingDefault :: OneConstructor -> Encoding

436−gOneConstructorToEncodingDefault = genericToEncoding defaultOptions

437−

438−gOneConstructorParseJSONDefault :: Value -> Parser OneConstructor

439−gOneConstructorParseJSONDefault = genericParseJSON defaultOptions

440−

441−gOneConstructorToJSONTagged :: OneConstructor -> Value

442−gOneConstructorToJSONTagged = genericToJSON optsTagSingleConstructors

443−

444−gOneConstructorToEncodingTagged :: OneConstructor -> Encoding

445−gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors

446−

447−gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

448−gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors

449−

450−--------------------------------------------------------------------------------

451−-- Product2 encoders/decoders

452−--------------------------------------------------------------------------------

453−

454−thProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)

455−thProduct2ParseJSON = $(mkParseJSON defaultOptions ''Product2)

456−

457−gProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)

458−gProduct2ParseJSON = genericParseJSON defaultOptions

tests/ErrorMessages.hsdeleted−224

@@ -1,224 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module ErrorMessages

6− (

7− tests

8− ) where

9−

10−import Prelude.Compat

11−

12−import Data.Aeson (FromJSON(..), Value, json)

13−import Data.Aeson.Types (Parser)

14−import Data.Aeson.Parser (eitherDecodeWith)

15−import Data.Aeson.Internal (formatError, iparse)

16−import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff)

17−import Data.Proxy (Proxy(..))

18−import Data.Semigroup ((<>))

19−import Data.Sequence (Seq)

20−import Instances ()

21−import Numeric.Natural (Natural)

22−import Test.Tasty (TestTree, TestName)

23−import Test.Tasty.Golden.Advanced (goldenTest)

24−import qualified Data.ByteString.Lazy.Char8 as L

25−import qualified Data.HashMap.Strict as HM

26−

27−import Encoders

28−import Types

29−

30−tests :: [TestTree]

31−tests =

32− [ aesonGoldenTest "simple" "tests/golden/simple.expected" output

33− , aesonGoldenTest "generic" "tests/golden/generic.expected" (outputGeneric G)

34− ]

35−

36−output :: Output

37−output = concat

38− [ testFor "Int" (Proxy :: Proxy Int)

39− [ "\"\""

40− , "[]"

41− , "{}"

42− , "null"

43− ]

44−

45− , testFor "Integer" (Proxy :: Proxy Integer)

46− [ "44.44"

47− ]

48−

49− , testFor "Natural" (Proxy :: Proxy Natural)

50− [ "44.44"

51− , "-50"

52− ]

53−

54− , testFor "String" (Proxy :: Proxy String)

55− [ "1"

56− , "[]"

57− , "{}"

58− , "null"

59− ]

60−

61− , testFor "HashMap" (Proxy :: Proxy (HM.HashMap String Int))

62− [ "\"\""

63− , "[]"

64− ]

65−

66− -- issue #356

67− , testFor "Either" (Proxy :: Proxy (Int, Either (Int, Bool) ()))

68− [ "[1,{\"Left\":[2,3]}]"

69− ]

70−

71− -- issue #358

72− , testFor "Seq" (Proxy :: Proxy (Seq Int))

73− [ "[0,1,true]"

74− ]

75− ]

76−

77−data Choice = TH | G

78−

79−outputGeneric :: Choice -> Output

80−outputGeneric choice = concat

81− [ testWith "OneConstructor"

82− (select

83− thOneConstructorParseJSONDefault

84− gOneConstructorParseJSONDefault)

85− [ "\"X\""

86− , "[0]"

87− ]

88−

89− , testWith "Nullary"

90− (select

91− thNullaryParseJSONString

92− gNullaryParseJSONString)

93− [ "\"X\""

94− , "[]"

95− ]

96−

97− , testWithSomeType "SomeType (tagged)"

98− (select

99− thSomeTypeParseJSONTaggedObject

100− gSomeTypeParseJSONTaggedObject)

101− [ "{\"tag\": \"unary\", \"contents\": true}"

102− , "{\"tag\": \"unary\"}"

103− , "{\"tag\": \"record\"}"

104− , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"

105− , "{\"tag\": \"X\"}"

106− , "{}"

107− , "[]"

108− ]

109−

110− , testWithSomeType "SomeType (single-field)"

111− (select

112− thSomeTypeParseJSONObjectWithSingleField

113− gSomeTypeParseJSONObjectWithSingleField)

114− [ "{\"unary\": {}}"

115− , "{\"unary\": []}"

116− , "{\"X\": []}"

117− , "{\"record\": {}, \"W\":{}}"

118− , "{}"

119− , "[]"

120− , "{\"unary\""

121− , "{\"unary\":"

122− , "{\"unary\":1"

123− ]

124−

125− , testWithSomeType "SomeType (two-element array)"

126− (select

127− thSomeTypeParseJSON2ElemArray

128− gSomeTypeParseJSON2ElemArray)

129− [ "[\"unary\", true]"

130− , "[\"record\", null]"

131− , "[\"X\", 0]"

132− , "[null, 0]"

133− , "[]"

134− , "{}"

135− , "[1"

136− , "[1,"

137− ]

138−

139− , testWithSomeType "SomeType (reject unknown fields)"

140− (select

141− thSomeTypeParseJSONRejectUnknownFields

142− gSomeTypeParseJSONRejectUnknownFields)

143− [ "{\"tag\": \"record\", \"testOne\": 1.0, \"testZero\": 1}"

144− , "{\"testZero\": 1}"

145− , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"

146− ]

147−

148− , testWithFoo "Foo (reject unknown fields)"

149− (select

150− thFooParseJSONRejectUnknownFields

151− gFooParseJSONRejectUnknownFields)

152− [ "{\"tag\": \"foo\"}"

153− ]

154−

155− , testWithFoo "Foo (reject unknown fields, tagged single)"

156− (select

157− thFooParseJSONRejectUnknownFieldsTagged

158− gFooParseJSONRejectUnknownFieldsTagged)

159− [ "{\"tag\": \"foo\", \"unknownField\": 0}"

160− ]

161−

162− , testWith "EitherTextInt"

163− (select

164− thEitherTextIntParseJSONUntaggedValue

165− gEitherTextIntParseJSONUntaggedValue)

166− [ "\"X\""

167− , "[]"

168− ]

169−

170− , testWith "Product2 Int Bool"

171− (select

172− thProduct2ParseJSON

173− gProduct2ParseJSON)

174− [ "[1, null]"

175− , "[]"

176− , "{}"

177− ]

178− ]

179− where

180− select a b = case choice of

181− TH -> a

182− G -> b

183−

184−-- Test infrastructure

185−

186−type Output = [String]

187−

188−outputLine :: String -> Output

189−outputLine = pure

190−

191−aesonGoldenTest :: TestName -> FilePath -> Output -> TestTree

192−aesonGoldenTest name ref out = goldenTest name (L.readFile ref) act cmp upd

193− where

194− act = pure (L.pack (unlines out))

195− upd = L.writeFile ref

196− cmp x y | x == y = return Nothing

197− cmp x y = return $ Just $ unlines $

198− concatMap f (getGroupedDiff (L.lines x) (L.lines y))

199− where

200− f (First xs) = map (cons3 '-' . L.unpack) xs

201− f (Second ys) = map (cons3 '+' . L.unpack) ys

202− -- we print unchanged lines too. It shouldn't be a problem while we have

203− -- reasonably small examples

204− f (Both xs _) = map (cons3 ' ' . L.unpack) xs

205− -- we add three characters, so the changed lines are easier to spot

206− cons3 c cs = c : c : c : ' ' : cs

207−

208−testWith :: Show a => String -> (Value -> Parser a) -> [L.ByteString] -> Output

209−testWith name parser ts =

210− outputLine name <>

211− foldMap (\s ->

212− case eitherDecodeWith json (iparse parser) s of

213− Left err -> outputLine $ uncurry formatError err

214− Right a -> outputLine $ show a) ts

215−

216−testFor :: forall a proxy. (FromJSON a, Show a)

217− => String -> proxy a -> [L.ByteString] -> Output

218−testFor name _ = testWith name (parseJSON :: Value -> Parser a)

219−

220−testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output

221−testWithSomeType = testWith

222−

223−testWithFoo :: String -> (Value -> Parser Foo) -> [L.ByteString] -> Output

224−testWithFoo = testWith

tests/Functions.hs+1−2

@@ -1,11 +1,10 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

31module Functions

42 (

53 approxEq

64 , approxEqWith

75 ) where

7+import Prelude ()

98import Prelude.Compat

109

1110approxEq :: (Fractional a, Ord a) => a -> a -> Bool

tests/Instances.hs+68−7

@@ -1,19 +1,23 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE NoImplicitPrelude #-}

44{-# LANGUAGE OverloadedStrings #-}

55{-# LANGUAGE RecordWildCards #-}

6−

6+{-# LANGUAGE StandaloneDeriving #-}

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

99module Instances () where

1010

11+import Prelude ()

1112import Prelude.Compat

1213

1314import Control.Applicative (empty)

1415import Control.Monad

1516import Data.Aeson.Types

1617import Data.Function (on)

18+import Data.Functor.Compose (Compose (..))

19+import Data.Proxy (Proxy(..))

20+import Data.Tagged (Tagged(..))

1721import Data.Time (ZonedTime(..), TimeZone(..))

1822import Data.Time.Clock (UTCTime(..))

1923import Functions

@@ -21,15 +25,30 @@ import Test.QuickCheck (Arbitrary(..), elements, oneof)

2125import Types

2226import qualified Data.DList as DList

2327import qualified Data.HashMap.Strict as HM

28+import qualified Data.UUID.Types as UUID

29+

30+#if !MIN_VERSION_QuickCheck(2,9,0)

31+import Control.Applicative (Const(..))

32+import Data.List.NonEmpty (NonEmpty(..))

33+import Data.Functor.Identity (Identity (..))

34+import Data.Version

35+import Test.QuickCheck (getNonNegative, listOf1, resize)

36+#endif

2437

2538import Data.Orphans ()

2639import Test.QuickCheck.Instances ()

40+#if MIN_VERSION_base(4,7,0)

2741import Data.Hashable.Time ()

42+#endif

43+

44+#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)

45+import Numeric.Natural

46+#endif

2847

2948-- "System" types.

3049

3150instance Arbitrary DotNetTime where

32− arbitrary = DotNetTime `fmap` arbitrary

51+ arbitrary = DotNetTime `liftM` arbitrary

3352 shrink = map DotNetTime . shrink . fromDotNetTime

3453

3554-- | Compare timezone part only on 'timeZoneMinutes'

@@ -153,15 +172,57 @@ instance Arbitrary EitherTextInt where

153172instance Arbitrary (GADT String) where

154173 arbitrary = GADT <$> arbitrary

155174

156−instance Arbitrary OptionField where

157− arbitrary = OptionField <$> arbitrary

158−

159−

160175instance ApproxEq Char where

161176 (=~) = (==)

162177

163178instance (ApproxEq a) => ApproxEq [a] where

164179 a =~ b = length a == length b && all (uncurry (=~)) (zip a b)

165180

181+-- Version tags are deprecated, so we avoid using them in the Arbitrary

182+-- instance. However, the recommended constructor 'makeVersion' is not

183+-- exported by "Data.Version" until base-4.8.0.0. For previous versions,

184+-- a definition is given below.

185+

186+

187+#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)

188+instance Arbitrary Natural where

189+ arbitrary = fromInteger . abs <$> arbitrary

190+#endif

191+

192+instance Arbitrary (Proxy a) where

193+ arbitrary = pure Proxy

194+

195+instance Arbitrary b => Arbitrary (Tagged a b) where

196+ arbitrary = Tagged <$> arbitrary

197+

166198instance Arbitrary a => Arbitrary (DList.DList a) where

167199 arbitrary = DList.fromList <$> arbitrary

200+

201+instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where

202+ arbitrary = Compose <$> arbitrary

203+

204+#if !MIN_VERSION_QuickCheck(2,9,0)

205+instance Arbitrary a => Arbitrary (Const a b) where

206+ arbitrary = Const <$> arbitrary

207+

208+instance Arbitrary a => Arbitrary (NonEmpty a) where

209+ arbitrary = (:|) <$> arbitrary <*> arbitrary

210+

211+instance Arbitrary Version where

212+ arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)

213+

214+#if !MIN_VERSION_base(4,8,0)

215+makeVersion :: [Int] -> Version

216+makeVersion b = Version b []

217+#endif

218+

219+instance Arbitrary a => Arbitrary (Identity a) where

220+ arbitrary = Identity <$> arbitrary

221+#endif

222+

223+instance Arbitrary UUID.UUID where

224+ arbitrary = UUID.fromWords

225+ <$> arbitrary

226+ <*> arbitrary

227+ <*> arbitrary

228+ <*> arbitrary

tests/JSONTestSuite/parsers/test_haskell-aeson/src/Main.hs+1−1

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

11{-# LANGUAGE ScopedTypeVariables #-}

3−module Main (main) where

3+module Main where

55import qualified Data.Aeson as Aeson

66import qualified Data.ByteString as Bytes

tests/JSONTestSuite/parsers/test_haskell-aeson/testaeson.cabal+3−5

@@ -1,8 +1,6 @@

1−-- This file has been generated from package.yaml by hpack version 0.28.2.

1+-- This file has been generated from package.yaml by hpack version 0.14.0.

22--

33-- see: https://github.com/sol/hpack

4−--

5−-- hash: 716ef4c3e64849526f097b85ed05015e0072c2e2afcc1f91e58d8bea68b123b2

75name: testaeson

86version: 0.0.0

@@ -14,8 +12,8 @@ executable testaeson

1412 hs-source-dirs:

1513 src

1614 build-depends:

17− aeson

18− , base >=4.7 && <5

15+ base >= 4.7 && < 5

16+ , aeson

1917 , base-prelude

2018 , bytestring

2119 default-language: Haskell2010

tests/JSONTestSuite/test_parsing/n_structure_..json → tests/JSONTestSuite/test_parsing/n_structure_<.>.jsonrenamed

The content is the same.

tests/JSONTestSuite/test_parsing/n_structure_null.json → tests/JSONTestSuite/test_parsing/n_structure_<null>.jsonrenamed

The content is the same.

tests/Options.hs+2−26

@@ -1,7 +1,6 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module Options (module Options) where

1+module Options where

3+import Prelude ()

54import Prelude.Compat

76import Data.Aeson.Types

@@ -43,26 +42,3 @@ optsUntaggedValue :: Options

4342optsUntaggedValue = optsDefault

4443 { sumEncoding = UntaggedValue

4544 }

46−

47−optsTagSingleConstructors :: Options

48−optsTagSingleConstructors = optsDefault

49− { tagSingleConstructors = True

50− , allNullaryToStringTag = False

51− }

52−

53−optsOptionField :: Options

54−optsOptionField = optsDefault

55− { fieldLabelModifier = const "field"

56− , omitNothingFields = True

57− }

58−

59−optsRejectUnknownFields :: Options

60−optsRejectUnknownFields = optsDefault

61− { rejectUnknownFields = True

62− }

63−

64−optsRejectUnknownFieldsTagged :: Options

65−optsRejectUnknownFieldsTagged = optsDefault

66− { rejectUnknownFields = True

67− , tagSingleConstructors = True

68− }

tests/PropUtils.hsdeleted−208

@@ -1,208 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RankNTypes #-}

4−

5−module PropUtils (module PropUtils) where

6−

7−import Prelude.Compat

8−

9−import Data.Aeson (eitherDecode, encode)

10−import Data.Aeson.Encoding (encodingToLazyByteString)

11−import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)

12−import qualified Data.Aeson.Internal as I

13−import Data.Aeson.Parser (value)

14−import Data.Aeson.Types

15−import Data.HashMap.Strict (HashMap)

16−import Data.Hashable (Hashable)

17−import Data.Int (Int8)

18−import Data.Map (Map)

19−import Data.Time (ZonedTime)

20−import Encoders

21−import Instances ()

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

23−import Types

24−import qualified Data.Attoparsec.Lazy as L

25−import qualified Data.ByteString.Lazy.Char8 as L

26−import qualified Data.HashMap.Strict as H

27−import qualified Data.Map as Map

28−import qualified Data.Text as T

29−import qualified Data.Vector as V

30−

31−

32−encodeDouble :: Double -> Double -> Property

33−encodeDouble num denom

34− | isInfinite d || isNaN d = encode d === "null"

35− | otherwise = (read . L.unpack . encode) d === d

36− where d = num / denom

37−

38−encodeInteger :: Integer -> Property

39−encodeInteger i = encode i === L.pack (show i)

40−

41−toParseJSON :: (Eq a, Show a) =>

42− (Value -> Parser a) -> (a -> Value) -> a -> Property

43−toParseJSON parsejson tojson x =

44− case iparse parsejson . tojson $ x of

45− IError path msg -> failure "parse" (formatError path msg) x

46− ISuccess x' -> x === x'

47−

48−toParseJSON1

49− :: (Eq (f Int), Show (f Int))

50− => (forall a. LiftParseJSON f a)

51− -> (forall a. LiftToJSON f a)

52− -> f Int

53− -> Property

54−toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson

55− where

56− parsejson = parsejson1 parseJSON (listParser parseJSON)

57− tojson = tojson1 toJSON (listValue toJSON)

58−

59−roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>

60− (a -> a -> Property) -> a -> a -> Property

61−roundTripEnc eq _ i =

62− case fmap ifromJSON . L.parse value . encode $ i of

63− L.Done _ (ISuccess v) -> v `eq` i

64− L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i

65− L.Fail _ _ err -> failure "parse" err i

66−

67−roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>

68− (a -> a -> Property) -> a -> a -> Property

69−roundTripNoEnc eq _ i =

70− case ifromJSON . toJSON $ i of

71− (ISuccess v) -> v `eq` i

72− (IError path err) -> failure "fromJSON" (formatError path err) i

73−

74−roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property

75−roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y

76−

77−-- We test keys by encoding HashMap and Map with it

78−roundTripKey

79− :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)

80− => a -> HashMap a Int -> Map a Int -> Property

81−roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m

82−

83−infix 4 ==~

84−(==~) :: (ApproxEq a, Show a) => a -> a -> Property

85−x ==~ y =

86− counterexample (show x ++ " /= " ++ show y) (x =~ y)

87−

88−toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property

89−toFromJSON x = case ifromJSON (toJSON x) of

90− IError path err -> failure "fromJSON" (formatError path err) x

91− ISuccess x' -> x === x'

92−

93−modifyFailureProp :: String -> String -> Bool

94−modifyFailureProp orig added =

95− result == Error (added ++ orig)

96− where

97− parser = const $ modifyFailure (added ++) $ fail orig

98− result :: Result ()

99− result = parse parser ()

100−

101−parserThrowErrorProp :: String -> Property

102−parserThrowErrorProp msg =

103− result === Error msg

104− where

105− parser = const $ parserThrowError [] msg

106− result :: Result ()

107− result = parse parser ()

108−

109−-- | Tests (also) that we catch the JSONPath and it has elements in the right order.

110−parserCatchErrorProp :: [String] -> String -> Property

111−parserCatchErrorProp path msg =

112− result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)

113− where

114− parser = parserCatchError outer (curry pure)

115−

116− outer = inner I.<?> I.Key "outer"

117− inner = parserThrowError jsonPath msg I.<?> I.Key "inner"

118−

119− result :: Result (I.JSONPath, String)

120− result = parse (const parser) ()

121−

122− jsonPath = map (I.Key . T.pack) path

123−

124−-- | Perform a structural comparison of the results of two encoding

125−-- methods. Compares decoded values to account for HashMap-driven

126−-- variation in JSON object key ordering.

127−sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property

128−sameAs toVal toEnc v =

129− counterexample (show s) $

130− eitherDecode s === Right (toVal v)

131− where

132− s = encodingToLazyByteString (toEnc v)

133−

134−sameAs1

135− :: (forall a. LiftToJSON f a)

136− -> (forall a. LiftToEncoding f a)

137− -> f Int

138− -> Property

139−sameAs1 toVal1 toEnc1 v = lhs === rhs

140− where

141− rhs = Right $ toVal1 toJSON (listValue toJSON) v

142− lhs = eitherDecode . encodingToLazyByteString $

143− toEnc1 toEncoding (listEncoding toEncoding) v

144−

145−sameAs1Agree

146− :: ToJSON a

147− => (f a -> Encoding)

148− -> (forall b. LiftToEncoding f b)

149− -> f a

150− -> Property

151−sameAs1Agree toEnc toEnc1 v = rhs === lhs

152− where

153− rhs = encodingToLazyByteString $ toEnc v

154− lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v

155−

156−type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()

157−type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)

158−

159−--------------------------------------------------------------------------------

160−-- Value properties

161−--------------------------------------------------------------------------------

162−

163−-- | Add the formatted @Value@ to the printed counterexample when the property

164−-- fails.

165−checkValue :: Testable a => (Value -> a) -> Value -> Property

166−checkValue prop v = counterexample (L.unpack (encode v)) (prop v)

167−

168−isString :: Value -> Bool

169−isString (String _) = True

170−isString _ = False

171−

172−is2ElemArray :: Value -> Bool

173−is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)

174−is2ElemArray _ = False

175−

176−isTaggedObjectValue :: Value -> Bool

177−isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&

178− "contents" `H.member` obj

179−isTaggedObjectValue _ = False

180−

181−isNullaryTaggedObject :: Value -> Bool

182−isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj

183−

184−isTaggedObject :: Value -> Property

185−isTaggedObject = checkValue isTaggedObject'

186−

187−isTaggedObject' :: Value -> Bool

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

189−isTaggedObject' _ = False

190−

191−isObjectWithSingleField :: Value -> Bool

192−isObjectWithSingleField (Object obj) = H.size obj == 1

193−isObjectWithSingleField _ = False

194−

195−-- | is untaggedValue of EitherTextInt

196−isUntaggedValueETI :: Value -> Bool

197−isUntaggedValueETI (String s)

198− | s == "nonenullary" = True

199−isUntaggedValueETI (Bool _) = True

200−isUntaggedValueETI (Number _) = True

201−isUntaggedValueETI (Array a) = length a == 2

202−isUntaggedValueETI _ = False

203−

204−isEmptyArray :: Value -> Property

205−isEmptyArray = checkValue isEmptyArray'

206−

207−isEmptyArray' :: Value -> Bool

208−isEmptyArray' = (Array mempty ==)

tests/Properties.hs+448−17

@@ -1,28 +1,288 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleContexts #-} -- For arbitrary Compose

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

3−module Properties (module Properties) where

7+module Properties where

9+import Prelude ()

510import Prelude.Compat

611

12+import Control.Applicative (Const)

13+import Data.Aeson (eitherDecode, encode)

14+import Data.Aeson.Encoding (encodingToLazyByteString)

15+import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)

16+import Data.Aeson.Parser (value)

17+import Data.Aeson.Types

18+import Data.DList (DList)

19+import Data.Functor.Compose (Compose (..))

20+import Data.HashMap.Strict (HashMap)

21+import Data.Hashable (Hashable)

22+import Data.Int (Int8)

23+import Data.List.NonEmpty (NonEmpty)

24+import Data.Map (Map)

25+import Data.Proxy (Proxy)

26+import Data.Ratio (Ratio)

27+import Data.Sequence (Seq)

28+import Data.Tagged (Tagged)

29+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

30+import Data.Version (Version)

31+import Encoders

732import Instances ()

8−import Test.Tasty (TestTree, testGroup)

9−import Test.Tasty.QuickCheck (testProperty)

10−import Test.QuickCheck (Property)

11−import PropUtils

12−import PropertyGeneric

13−import PropertyKeys

14−import PropertyRoundTrip

15−import PropertyTH

33+import Numeric.Natural (Natural)

34+import Test.Framework (Test, testGroup)

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

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

37+import Types

38+import qualified Data.Attoparsec.Lazy as L

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

40+import qualified Data.HashMap.Strict as H

41+import qualified Data.Map as Map

42+import qualified Data.Text as T

43+import qualified Data.Text.Lazy as LT

44+import qualified Data.UUID.Types as UUID

45+import qualified Data.Vector as V

1646

47+encodeDouble :: Double -> Double -> Property

48+encodeDouble num denom

49+ | isInfinite d || isNaN d = encode d === "null"

50+ | otherwise = (read . L.unpack . encode) d === d

51+ where d = num / denom

1752

18−tests :: TestTree

53+encodeInteger :: Integer -> Property

54+encodeInteger i = encode i === L.pack (show i)

55+

56+toParseJSON :: (Eq a, Show a) =>

57+ (Value -> Parser a) -> (a -> Value) -> a -> Property

58+toParseJSON parsejson tojson x =

59+ case iparse parsejson . tojson $ x of

60+ IError path msg -> failure "parse" (formatError path msg) x

61+ ISuccess x' -> x === x'

62+

63+toParseJSON1

64+ :: (Eq (f Int), Show (f Int))

65+ => (forall a. LiftParseJSON f a)

66+ -> (forall a. LiftToJSON f a)

67+ -> f Int

68+ -> Property

69+toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson

70+ where

71+ parsejson = parsejson1 parseJSON (listParser parseJSON)

72+ tojson = tojson1 toJSON (listValue toJSON)

73+

74+roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>

75+ (a -> a -> Property) -> a -> a -> Property

76+roundTripEnc eq _ i =

77+ case fmap ifromJSON . L.parse value . encode $ i of

78+ L.Done _ (ISuccess v) -> v `eq` i

79+ L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i

80+ L.Fail _ _ err -> failure "parse" err i

81+

82+roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>

83+ (a -> a -> Property) -> a -> a -> Property

84+roundTripNoEnc eq _ i =

85+ case ifromJSON . toJSON $ i of

86+ (ISuccess v) -> v `eq` i

87+ (IError path err) -> failure "fromJSON" (formatError path err) i

88+

89+roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property

90+roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y

91+

92+-- We test keys by encoding HashMap and Map with it

93+roundTripKey

94+ :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)

95+ => a -> HashMap a Int -> Map a Int -> Property

96+roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m

97+

98+infix 4 ==~

99+(==~) :: (ApproxEq a, Show a) => a -> a -> Property

100+x ==~ y =

101+ counterexample (show x ++ " /= " ++ show y) (x =~ y)

102+

103+toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property

104+toFromJSON x = case ifromJSON (toJSON x) of

105+ IError path err -> failure "fromJSON" (formatError path err) x

106+ ISuccess x' -> x === x'

107+

108+modifyFailureProp :: String -> String -> Bool

109+modifyFailureProp orig added =

110+ result == Error (added ++ orig)

111+ where

112+ parser = const $ modifyFailure (added ++) $ fail orig

113+ result :: Result ()

114+ result = parse parser ()

115+

116+-- | Perform a structural comparison of the results of two encoding

117+-- methods. Compares decoded values to account for HashMap-driven

118+-- variation in JSON object key ordering.

119+sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property

120+sameAs toVal toEnc v =

121+ eitherDecode (encodingToLazyByteString (toEnc v)) === Right (toVal v)

122+

123+sameAs1

124+ :: (forall a. LiftToJSON f a)

125+ -> (forall a. LiftToEncoding f a)

126+ -> f Int

127+ -> Property

128+sameAs1 toVal1 toEnc1 v = lhs === rhs

129+ where

130+ rhs = Right $ toVal1 toJSON (listValue toJSON) v

131+ lhs = eitherDecode . encodingToLazyByteString $

132+ toEnc1 toEncoding (listEncoding toEncoding) v

133+

134+sameAs1Agree

135+ :: ToJSON a

136+ => (f a -> Encoding)

137+ -> (forall b. LiftToEncoding f b)

138+ -> f a

139+ -> Property

140+sameAs1Agree toEnc toEnc1 v = rhs === lhs

141+ where

142+ rhs = encodingToLazyByteString $ toEnc v

143+ lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v

144+

145+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()

146+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)

147+

148+--------------------------------------------------------------------------------

149+-- Value properties

150+--------------------------------------------------------------------------------

151+

152+isString :: Value -> Bool

153+isString (String _) = True

154+isString _ = False

155+

156+is2ElemArray :: Value -> Bool

157+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)

158+is2ElemArray _ = False

159+

160+isTaggedObjectValue :: Value -> Bool

161+isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&

162+ "contents" `H.member` obj

163+isTaggedObjectValue _ = False

164+

165+isNullaryTaggedObject :: Value -> Bool

166+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj

167+

168+isTaggedObject :: Value -> Bool

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

170+isTaggedObject _ = False

171+

172+isObjectWithSingleField :: Value -> Bool

173+isObjectWithSingleField (Object obj) = H.size obj == 1

174+isObjectWithSingleField _ = False

175+

176+-- | is untaggedValue of EitherTextInt

177+isUntaggedValueETI :: Value -> Bool

178+isUntaggedValueETI (String s)

179+ | s == "nonenullary" = True

180+isUntaggedValueETI (Bool _) = True

181+isUntaggedValueETI (Number _) = True

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

183+isUntaggedValueETI _ = False

184+

185+

186+--------------------------------------------------------------------------------

187+

188+

189+tests :: Test

19190tests = testGroup "properties" [

20191 testGroup "encode" [

21192 testProperty "encodeDouble" encodeDouble

22193 , testProperty "encodeInteger" encodeInteger

23194 ]

24− , roundTripTests

25− , keysTests

195+ , testGroup "roundTrip" [

196+ testProperty "Bool" $ roundTripEq True

197+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)

198+ , testProperty "Int" $ roundTripEq (1 :: Int)

199+ , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)

200+ , testProperty "Integer" $ roundTripEq (1 :: Integer)

201+ , testProperty "String" $ roundTripEq ("" :: String)

202+ , testProperty "Text" $ roundTripEq T.empty

203+ , testProperty "Lazy Text" $ roundTripEq LT.empty

204+ , testProperty "Foo" $ roundTripEq (undefined :: Foo)

205+ , testProperty "Day" $ roundTripEq (undefined :: Day)

206+ , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)

207+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)

208+ , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)

209+ , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)

210+ , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)

211+ , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)

212+ , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)

213+ , testProperty "Version" $ roundTripEq (undefined :: Version)

214+ , testProperty "Natural" $ roundTripEq (undefined :: Natural)

215+ , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)

216+ , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)

217+ , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)

218+ , testProperty "DList" $ roundTripEq (undefined :: DList Int)

219+ , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)

220+ , testProperty "Rational" $ roundTripEq (undefined :: Rational)

221+ , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)

222+ , testProperty "UUID" $ roundTripEq UUID.nil

223+ , testGroup "functors"

224+ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)

225+

226+ , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)

227+ , testProperty "Identity [Char]" $ roundTripEq (undefined :: I [Char])

228+ , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])

229+

230+ , testProperty "Compose I I Int" $ roundTripEq (undefined :: Compose I I Int)

231+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: Compose [] I Int)

232+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: Compose I [] Int)

233+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: Compose [] [] Int)

234+

235+ , testProperty "Compose I I Char" $ roundTripEq (undefined :: Compose I I Char)

236+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: Compose [] I Char)

237+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: Compose I [] Char)

238+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: Compose [] [] Char)

239+

240+ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: Compose3 I I I Char)

241+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: Compose3 I [] I Char)

242+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: Compose3 I I [] Char)

243+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: Compose3 I [] [] Char)

244+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: Compose3 [] I I Char)

245+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: Compose3 [] [] I Char)

246+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: Compose3 [] I [] Char)

247+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: Compose3 [] [] [] Char)

248+

249+ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: Compose3' I I I Char)

250+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: Compose3' I [] I Char)

251+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: Compose3' I I [] Char)

252+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: Compose3' I [] [] Char)

253+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: Compose3' [] I I Char)

254+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: Compose3' [] [] I Char)

255+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: Compose3' [] I [] Char)

256+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: Compose3' [] [] [] Char)

257+ ]

258+ , testGroup "ghcGenerics" [

259+ testProperty "OneConstructor" $ roundTripEq OneConstructor

260+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)

261+ , testProperty "Product6" $ roundTripEq (undefined :: P6)

262+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)

263+ ]

264+ ]

265+ , testGroup "roundTrip Key"

266+ [ testProperty "Bool" $ roundTripKey True

267+ , testProperty "Text" $ roundTripKey (undefined :: T.Text)

268+ , testProperty "String" $ roundTripKey (undefined :: String)

269+ , testProperty "Int" $ roundTripKey (undefined :: Int)

270+ , testProperty "[Text]" $ roundTripKey (undefined :: [T.Text])

271+ , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))

272+ , testProperty "Integer" $ roundTripKey (undefined :: Integer)

273+ , testProperty "Natural" $ roundTripKey (undefined :: Natural)

274+ , testProperty "Float" $ roundTripKey (undefined :: Float)

275+ , testProperty "Double" $ roundTripKey (undefined :: Double)

276+#if MIN_VERSION_base(4,7,0)

277+ , testProperty "Day" $ roundTripKey (undefined :: Day)

278+ , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

279+ , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

280+ , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

281+#endif

282+ , testProperty "Version" $ roundTripKey (undefined :: Version)

283+ , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

284+ , testProperty "UUID" $ roundTripKey UUID.nil

285+ ]

26286 , testGroup "toFromJSON" [

27287 testProperty "Integer" (toFromJSON :: Integer -> Property)

28288 , testProperty "Double" (toFromJSON :: Double -> Property)

@@ -32,9 +292,180 @@ tests = testGroup "properties" [

32292 ]

33293 , testGroup "failure messages" [

34294 testProperty "modify failure" modifyFailureProp

35− , testProperty "parserThrowError" parserThrowErrorProp

36− , testProperty "parserCatchError" parserCatchErrorProp

37295 ]

38− , genericTests

39− , templateHaskellTests

296+ , testGroup "generic" [

297+ testGroup "toJSON" [

298+ testGroup "Nullary" [

299+ testProperty "string" (isString . gNullaryToJSONString)

300+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)

301+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)

302+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)

303+ , testGroup "roundTrip" [

304+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)

305+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)

306+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)

307+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

308+ ]

309+ ]

310+ , testGroup "EitherTextInt" [

311+ testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)

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

313+ ]

314+ , testGroup "SomeType" [

315+ testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)

316+ , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)

317+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)

318+ , testGroup "roundTrip" [

319+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)

320+ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)

321+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)

322+

323+#if __GLASGOW_HASKELL__ >= 706

324+ , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

325+ , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

326+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

327+#endif

328+ ]

329+ ]

330+ ]

331+ , testGroup "toEncoding" [

332+ testProperty "NullaryString" $

333+ gNullaryToJSONString `sameAs` gNullaryToEncodingString

334+ , testProperty "Nullary2ElemArray" $

335+ gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray

336+ , testProperty "NullaryTaggedObject" $

337+ gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject

338+ , testProperty "NullaryObjectWithSingleField" $

339+ gNullaryToJSONObjectWithSingleField `sameAs`

340+ gNullaryToEncodingObjectWithSingleField

341+ -- , testProperty "ApproxUnwrap" $

342+ -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap

343+ , testProperty "ApproxDefault" $

344+ gApproxToJSONDefault `sameAs` gApproxToEncodingDefault

345+

346+ , testProperty "EitherTextInt UntaggedValue" $

347+ gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue

348+

349+ , testProperty "SomeType2ElemArray" $

350+ gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

351+#if __GLASGOW_HASKELL__ >= 706

352+ , testProperty "SomeType2ElemArray unary" $

353+ gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

354+ , testProperty "SomeType2ElemArray unary agree" $

355+ gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

356+#endif

357+

358+ , testProperty "SomeTypeTaggedObject" $

359+ gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

360+#if __GLASGOW_HASKELL__ >= 706

361+ , testProperty "SomeTypeTaggedObject unary" $

362+ gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

363+ , testProperty "SomeTypeTaggedObject unary agree" $

364+ gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

365+#endif

366+

367+ , testProperty "SomeTypeObjectWithSingleField" $

368+ gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

369+#if __GLASGOW_HASKELL__ >= 706

370+ , testProperty "SomeTypeObjectWithSingleField unary" $

371+ gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

372+ , testProperty "SomeTypeObjectWithSingleField unary agree" $

373+ gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

374+#endif

375+

376+ , testProperty "SomeTypeOmitNothingFields" $

377+ gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

378+ ]

379+ ]

380+ , testGroup "template-haskell" [

381+ testGroup "toJSON" [

382+ testGroup "Nullary" [

383+ testProperty "string" (isString . thNullaryToJSONString)

384+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)

385+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)

386+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

387+

388+ , testGroup "roundTrip" [

389+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)

390+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)

391+ , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)

392+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)

393+ ]

394+ ]

395+ , testGroup "EitherTextInt" [

396+ testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)

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

398+ ]

399+ , testGroup "SomeType" [

400+ testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)

401+ , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)

402+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)

403+ , testGroup "roundTrip" [

404+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)

405+ , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)

406+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)

407+

408+ , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)

409+ , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)

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

411+

412+ ]

413+ , testGroup "Approx" [

414+ testProperty "string" (isString . thApproxToJSONUnwrap)

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

416+ , testGroup "roundTrip" [

417+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)

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

419+ ]

420+ ]

421+ , testGroup "GADT" [

422+ testProperty "string" (isString . thGADTToJSONUnwrap)

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

424+ , testGroup "roundTrip" [

425+ testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)

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

427+ ]

428+ ]

429+ ]

430+ ]

431+ , testGroup "toEncoding" [

432+ testProperty "NullaryString" $

433+ thNullaryToJSONString `sameAs` thNullaryToEncodingString

434+ , testProperty "Nullary2ElemArray" $

435+ thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray

436+ , testProperty "NullaryTaggedObject" $

437+ thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject

438+ , testProperty "NullaryObjectWithSingleField" $

439+ thNullaryToJSONObjectWithSingleField `sameAs`

440+ thNullaryToEncodingObjectWithSingleField

441+ , testProperty "ApproxUnwrap" $

442+ thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap

443+ , testProperty "ApproxDefault" $

444+ thApproxToJSONDefault `sameAs` thApproxToEncodingDefault

445+

446+ , testProperty "EitherTextInt UntaggedValue" $

447+ thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue

448+

449+ , testProperty "SomeType2ElemArray" $

450+ thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray

451+ , testProperty "SomeType2ElemArray unary" $

452+ thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray

453+ , testProperty "SomeType2ElemArray unary agree" $

454+ thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray

455+

456+ , testProperty "SomeTypeTaggedObject" $

457+ thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject

458+ , testProperty "SomeTypeTaggedObject unary" $

459+ thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject

460+ , testProperty "SomeTypeTaggedObject unary agree" $

461+ thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject

462+

463+ , testProperty "SomeTypeObjectWithSingleField" $

464+ thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField

465+ , testProperty "SomeTypeObjectWithSingleField unary" $

466+ thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField

467+ , testProperty "SomeTypeObjectWithSingleField unary agree" $

468+ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

469+ ]

470+ ]

40471 ]

tests/PropertyGeneric.hsdeleted−116

@@ -1,116 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NoImplicitPrelude #-}

3−

4−module PropertyGeneric ( genericTests ) where

5−

6−import Prelude.Compat

7−

8−import Data.Semigroup (Option(..))

9−import Encoders

10−import Instances ()

11−import Test.Tasty (TestTree, testGroup)

12−import Test.Tasty.QuickCheck (testProperty)

13−import Test.QuickCheck ( (===) )

14−import Types

15−import PropUtils

16−

17−

18−genericTests :: TestTree

19−genericTests =

20− testGroup "generic" [

21− testGroup "toJSON" [

22− testGroup "Nullary" [

23− testProperty "string" (isString . gNullaryToJSONString)

24− , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)

25− , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)

26− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)

27− , testGroup "roundTrip" [

28− testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)

29− , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)

30− , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)

31− , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)

32− ]

33− ]

34− , testGroup "EitherTextInt" [

35− testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)

36− , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)

37− ]

38− , testGroup "SomeType" [

39− testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)

40− , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)

41− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)

42− , testGroup "roundTrip" [

43− testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)

44− , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)

45− , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)

46−

47− , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

48− , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

49− , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

50− ]

51− ]

52− , testGroup "OneConstructor" [

53− testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)

54− , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)

55− , testGroup "roundTrip" [

56− testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)

57− , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)

58− ]

59− ]

60− , testGroup "OptionField" [

61− testProperty "like Maybe" $

62− \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)

63− , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)

64− ]

65− ]

66− , testGroup "toEncoding" [

67− testProperty "NullaryString" $

68− gNullaryToJSONString `sameAs` gNullaryToEncodingString

69− , testProperty "Nullary2ElemArray" $

70− gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray

71− , testProperty "NullaryTaggedObject" $

72− gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject

73− , testProperty "NullaryObjectWithSingleField" $

74− gNullaryToJSONObjectWithSingleField `sameAs`

75− gNullaryToEncodingObjectWithSingleField

76− -- , testProperty "ApproxUnwrap" $

77− -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap

78− , testProperty "ApproxDefault" $

79− gApproxToJSONDefault `sameAs` gApproxToEncodingDefault

80−

81− , testProperty "EitherTextInt UntaggedValue" $

82− gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue

83−

84− , testProperty "SomeType2ElemArray" $

85− gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

86− , testProperty "SomeType2ElemArray unary" $

87− gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

88− , testProperty "SomeType2ElemArray unary agree" $

89− gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

90−

91− , testProperty "SomeTypeTaggedObject" $

92− gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

93− , testProperty "SomeTypeTaggedObject unary" $

94− gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

95− , testProperty "SomeTypeTaggedObject unary agree" $

96− gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

97−

98− , testProperty "SomeTypeObjectWithSingleField" $

99− gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

100− , testProperty "SomeTypeObjectWithSingleField unary" $

101− gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

102− , testProperty "SomeTypeObjectWithSingleField unary agree" $

103− gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

104−

105− , testProperty "SomeTypeOmitNothingFields" $

106− gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

107−

108− , testProperty "OneConstructorDefault" $

109− gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault

110− , testProperty "OneConstructorTagged" $

111− gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged

112−

113− , testProperty "OptionField" $

114− gOptionFieldToJSON `sameAs` gOptionFieldToEncoding

115− ]

116− ]

tests/PropertyKeys.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module PropertyKeys ( keysTests ) where

4−

5−import Prelude.Compat

6−

7−import Data.Time (Day, LocalTime, TimeOfDay, UTCTime)

8−import Data.Version (Version)

9−import Instances ()

10−import Numeric.Natural (Natural)

11−import Test.Tasty (TestTree, testGroup)

12−import Test.Tasty.QuickCheck (testProperty)

13−import Types

14−import qualified Data.Text as T

15−import qualified Data.Text.Lazy as LT

16−import qualified Data.UUID.Types as UUID

17−import PropUtils

18−

19−

20−keysTests :: TestTree

21−keysTests =

22− testGroup "roundTrip Key"

23− [ testProperty "Bool" $ roundTripKey True

24− , testProperty "Text" $ roundTripKey (undefined :: T.Text)

25− , testProperty "String" $ roundTripKey (undefined :: String)

26− , testProperty "Int" $ roundTripKey (undefined :: Int)

27− , testProperty "[Text]" $ roundTripKey (undefined :: LogScaled [T.Text])

28− , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))

29− , testProperty "Integer" $ roundTripKey (undefined :: Integer)

30− , testProperty "Natural" $ roundTripKey (undefined :: Natural)

31− , testProperty "Float" $ roundTripKey (undefined :: Float)

32− , testProperty "Double" $ roundTripKey (undefined :: Double)

33− , testProperty "Day" $ roundTripKey (undefined :: Day)

34− , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

35− , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

36− , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

37− , testProperty "Version" $ roundTripKey (undefined :: Version)

38− , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

39− , testProperty "UUID" $ roundTripKey UUID.nil

40− ]

tests/PropertyRTFunctors.hsdeleted−51

@@ -1,51 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module PropertyRTFunctors ( roundTripFunctorsTests ) where

4−

5−import Prelude.Compat

6−

7−import Data.Functor.Compose (Compose (..))

8−import Instances ()

9−import Test.Tasty (TestTree, testGroup)

10−import Test.Tasty.QuickCheck (testProperty)

11−import Types

12−import PropUtils

13−

14−

15−roundTripFunctorsTests :: TestTree

16−roundTripFunctorsTests =

17− testGroup "functors"

18− [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)

19−

20− , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)

21− , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String)

22− , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])

23−

24− , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int))

25− , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))

26− , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))

27− , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))

28−

29− , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))

30− , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))

31− , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))

32− , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))

33−

34− , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))

35− , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))

36− , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))

37− , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))

38− , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))

39− , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))

40− , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))

41− , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))

42−

43− , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))

44− , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))

45− , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))

46− , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))

47− , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))

48− , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))

49− , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))

50− , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] [] Char))

51− ]

tests/PropertyRoundTrip.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module PropertyRoundTrip ( roundTripTests ) where

4−

5−import Prelude.Compat

6−

7−import Control.Applicative (Const)

8−import Data.Aeson.Types

9−import Data.DList (DList)

10−import Data.List.NonEmpty (NonEmpty)

11−import Data.Proxy (Proxy)

12−import Data.Ratio (Ratio)

13−import Data.Sequence (Seq)

14−import Data.Tagged (Tagged)

15−import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

16−import Data.Version (Version)

17−import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek)

18−import Data.Time.LocalTime.Compat (CalendarDiffTime)

19−import Data.Time.Clock.System.Compat (SystemTime)

20−import Instances ()

21−import Numeric.Natural (Natural)

22−import Test.Tasty (TestTree, testGroup)

23−import Test.Tasty.QuickCheck (testProperty)

24−import Types

25−import qualified Data.Text as T

26−import qualified Data.Text.Lazy as LT

27−import qualified Data.UUID.Types as UUID

28−import PropUtils

29−import PropertyRTFunctors

30−

31−

32−roundTripTests :: TestTree

33−roundTripTests =

34− testGroup "roundTrip" [

35− testProperty "Bool" $ roundTripEq True

36− , testProperty "Double" $ roundTripEq (1 :: Approx Double)

37− , testProperty "Int" $ roundTripEq (1 :: Int)

38− , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)

39− , testProperty "Integer" $ roundTripEq (1 :: Integer)

40− , testProperty "String" $ roundTripEq ("" :: String)

41− , testProperty "Text" $ roundTripEq T.empty

42− , testProperty "Lazy Text" $ roundTripEq LT.empty

43− , testProperty "Foo" $ roundTripEq (undefined :: Foo)

44− , testProperty "Day" $ roundTripEq (undefined :: Day)

45− , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)

46− , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)

47− , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)

48− , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)

49− , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)

50− , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)

51− , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)

52− , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)

53− , testProperty "DayOfWeek" $ roundTripEq (undefined :: DayOfWeek)

54− , testProperty "SystemTime" $ roundTripEq (undefined :: SystemTime)

55− , testProperty "CalendarDiffTime" $ roundTripEq (undefined :: CalendarDiffTime)

56− , testProperty "CalendarDiffDays" $ roundTripEq (undefined :: CalendarDiffDays)

57− , testProperty "Version" $ roundTripEq (undefined :: Version)

58− , testProperty "Natural" $ roundTripEq (undefined :: Natural)

59− , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)

60− , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)

61− , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)

62− , testProperty "DList" $ roundTripEq (undefined :: DList Int)

63− , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)

64− , testProperty "Rational" $ roundTripEq (undefined :: Rational)

65− , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)

66− , testProperty "UUID" $ roundTripEq UUID.nil

67− , roundTripFunctorsTests

68− , testGroup "ghcGenerics" [

69− testProperty "OneConstructor" $ roundTripEq OneConstructor

70− , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)

71− , testProperty "Product6" $ roundTripEq (undefined :: P6)

72− , testProperty "Sum4" $ roundTripEq (undefined :: S4)

73− ]

74− ]

tests/PropertyTH.hsdeleted−130

@@ -1,130 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

3−module PropertyTH ( templateHaskellTests ) where

4−

5−import Prelude.Compat

6−

7−import Data.Semigroup (Option(..))

8−import Encoders

9−import Instances ()

10−import Test.Tasty (TestTree, testGroup)

11−import Test.Tasty.QuickCheck (testProperty)

12−import Test.QuickCheck ( (===) )

13−import Types

14−import PropUtils

15−

16−

17−templateHaskellTests :: TestTree

18−templateHaskellTests =

19− testGroup "template-haskell" [

20− testGroup "toJSON" [

21− testGroup "Nullary" [

22− testProperty "string" (isString . thNullaryToJSONString)

23− , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)

24− , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)

25− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

26−

27− , testGroup "roundTrip" [

28− testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)

29− , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)

30− , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)

31− , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)

32− ]

33− ]

34− , testGroup "EitherTextInt" [

35− testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)

36− , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)

37− ]

38− , testGroup "SomeType" [

39− testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)

40− , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)

41− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)

42− , testGroup "roundTrip" [

43− testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)

44− , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)

45− , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)

46−

47− , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)

48− , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)

49− , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)

50−

51− ]

52− ]

53− , testGroup "Approx" [

54− testProperty "string" (isString . thApproxToJSONUnwrap)

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

56− , testGroup "roundTrip" [

57− testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)

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

59− ]

60− ]

61− , testGroup "GADT" [

62− testProperty "string" (isString . thGADTToJSONUnwrap)

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

64− , testGroup "roundTrip" [

65− testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)

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

67− ]

68− ]

69− , testGroup "OneConstructor" [

70− testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)

71− , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)

72− , testGroup "roundTrip" [

73− testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)

74− , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)

75− ]

76− ]

77− , testGroup "OptionField" [

78− testProperty "like Maybe" $

79− \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)

80− , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)

81− ]

82− ]

83− , testGroup "toEncoding" [

84− testProperty "NullaryString" $

85− thNullaryToJSONString `sameAs` thNullaryToEncodingString

86− , testProperty "Nullary2ElemArray" $

87− thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray

88− , testProperty "NullaryTaggedObject" $

89− thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject

90− , testProperty "NullaryObjectWithSingleField" $

91− thNullaryToJSONObjectWithSingleField `sameAs`

92− thNullaryToEncodingObjectWithSingleField

93− , testProperty "ApproxUnwrap" $

94− thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap

95− , testProperty "ApproxDefault" $

96− thApproxToJSONDefault `sameAs` thApproxToEncodingDefault

97−

98− , testProperty "EitherTextInt UntaggedValue" $

99− thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue

100−

101− , testProperty "SomeType2ElemArray" $

102− thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray

103− , testProperty "SomeType2ElemArray unary" $

104− thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray

105− , testProperty "SomeType2ElemArray unary agree" $

106− thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray

107−

108− , testProperty "SomeTypeTaggedObject" $

109− thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject

110− , testProperty "SomeTypeTaggedObject unary" $

111− thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject

112− , testProperty "SomeTypeTaggedObject unary agree" $

113− thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject

114−

115− , testProperty "SomeTypeObjectWithSingleField" $

116− thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField

117− , testProperty "SomeTypeObjectWithSingleField unary" $

118− thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField

119− , testProperty "SomeTypeObjectWithSingleField unary agree" $

120− thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField

121−

122− , testProperty "OneConstructorDefault" $

123− thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault

124− , testProperty "OneConstructorTagged" $

125− thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged

126−

127− , testProperty "OptionField" $

128− thOptionFieldToJSON `sameAs` thOptionFieldToEncoding

129− ]

130− ]

tests/SerializationFormatSpec.hsdeleted−294

@@ -1,294 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE DataKinds #-}

7−

8−------------------------------------------------------------------------------

9−-- These tests assert that the JSON serialization doesn't change by accident.

10−-----------------------------------------------------------------------------

11−

12−module SerializationFormatSpec

13− (

14− tests

15− ) where

16−

17−import Prelude.Compat

18−

19−import Control.Applicative (Const(..))

20−import Data.Aeson (FromJSON(..), decode, encode, genericParseJSON, genericToEncoding, genericToJSON)

21−import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), defaultOptions)

22−import Data.Fixed (Pico)

23−import Data.Foldable (for_, toList)

24−import Data.Functor.Compose (Compose(..))

25−import Data.Functor.Identity (Identity(..))

26−import Data.Functor.Product (Product(..))

27−import Data.Functor.Sum (Sum(..))

28−import Data.List.NonEmpty (NonEmpty(..))

29−import Data.Proxy (Proxy(..))

30−import Data.Scientific (Scientific)

31−import Data.Tagged (Tagged(..))

32−import Data.Time (fromGregorian)

33−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

34−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

35−import Data.Time.Clock.System.Compat (SystemTime (..))

36−import Data.Word (Word8)

37−import GHC.Generics (Generic)

38−import Instances ()

39−import Test.Tasty (TestTree, testGroup)

40−import Test.Tasty.HUnit (assertFailure, assertEqual, testCase)

41−import Types (Approx(..), Compose3, Compose3', I)

42−import qualified Data.ByteString.Lazy.Char8 as L

43−import qualified Data.DList as DList

44−import qualified Data.HashMap.Strict as HM

45−import qualified Data.HashSet as HashSet

46−import qualified Data.IntMap as IntMap

47−import qualified Data.IntSet as IntSet

48−import qualified Data.Map as M

49−import qualified Data.Monoid as Monoid

50−import qualified Data.Semigroup as Semigroup

51−import qualified Data.Sequence as Seq

52−import qualified Data.Set as Set

53−import qualified Data.Tree as Tree

54−import qualified Data.UUID.Types as UUID

55−import qualified Data.Vector as Vector

56−

57−tests :: [TestTree]

58−tests =

59− [

60− testGroup "To JSON representation" $ fmap assertJsonEncodingExample jsonEncodingExamples

61− , testGroup "From JSON representation" $ fmap assertJsonExample jsonDecodingExamples

62− , testGroup "To/From JSON representation" $ fmap assertJsonExample jsonExamples

63−

64− ]

65−

66−jsonExamples :: [Example]

67−jsonExamples =

68− [

69− example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

70− , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

71− , example "Nothing" "null" (Nothing :: Maybe Int)

72− -- Maybe serialising is lossy

73− -- https://github.com/bos/aeson/issues/376

74− , Example "Just Nothing" ["null"] (Just Nothing :: Maybe (Maybe Int)) Nothing

75− , example "Just" "1" (Just 1 :: Maybe Int)

76− , example "Proxy Int" "null" (Proxy :: Proxy Int)

77− , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

78− -- Test Tagged instance is polykinded

79− , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

80− , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

81− , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

82− , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

83− , example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)

84− , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

85− , example "()" "[]" ()

86−

87− , ndExample "HashMap Int Int"

88− [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

89− (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

90− , ndExample "Map Int Int"

91− [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

92− (M.fromList [(0,1),(2,3)] :: M.Map Int Int)

93− , ndExample "Map (Tagged Int Int) Int"

94− [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

95− (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)

96− , example "Map [Int] Int"

97− "[[[0],1],[[2],3]]"

98− (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)

99− , ndExample "Map [Char] Int"

100− [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

101− (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)

102− , ndExample "Map [I Char] Int"

103− [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

104− (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)

105−

106− , example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)

107−

108− , example "Ordering LT" "\"LT\"" LT

109− , example "Ordering EQ" "\"EQ\"" EQ

110− , example "Ordering GT" "\"GT\"" GT

111−

112− , example "Float" "3.14" (3.14 :: Float)

113− , example "Pico" "3.14" (3.14 :: Pico)

114− , example "Scientific" "3.14" (3.14 :: Scientific)

115−

116− , example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords

117− 0xc2cc10e1 0x57d64b6f 0x989938d9 0x72112d8c

118−

119− , example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)

120− , example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])

121− , example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)

122− , example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)

123− , example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)

124− , example "Tree Int" "[1,[[2,[[3,[]],[4,[]]]],[5,[]]]]" (let n = Tree.Node in n 1 [n 2 [n 3 [], n 4 []], n 5 []] :: Tree.Tree Int)

125−

126− -- Three separate cases, as ordering in HashMap is not defined

127− , example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))

128− , example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)

129− , example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)

130−

131− -- Functors

132− , example "Identity Int" "1" (pure 1 :: Identity Int)

133−

134− , example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)

135− , example "Identity String" "\"foo\"" (pure "foo" :: Identity String)

136− , example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])

137−

138− , example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)

139− , example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

140− , example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])

141−

142− , example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)

143− , example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)

144− , example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)

145− , example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)

146− , example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)

147−

148− , example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)

149− , example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)

150− , example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)

151−

152− , example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)

153− , example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)

154− , example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)

155−

156− , example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

157− , example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)

158− , example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)

159− , example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)

160−

161− , example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)

162− , example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)

163− , example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)

164− , example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)

165−

166− , example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)

167− , example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)

168− , example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)

169− , example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)

170− , example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)

171− , example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)

172− , example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)

173− , example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char)

174−

175− , example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)

176− , example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)

177− , example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)

178− , example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)

179− , example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)

180− , example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)

181− , example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)

182− , example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)

183−

184− , example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String)

185− , example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String)

186−

187− -- newtypes from Monoid/Semigroup

188− , example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)

189− , example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)

190− , example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)

191− , example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)

192− , example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)

193− , example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)

194− , example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)

195− , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)

196− , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)

197− , example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))

198−

199− -- time 1.9

200− , example "SystemTime" "123.123456789" (MkSystemTime 123 123456789)

201− , Example "SystemTime" ["124.23456789"]

202− (MkSystemTime 123 1234567890)

203− (MkSystemTime 124 234567890)

204− , ndExample "CalendarDiffTime"

205− [ "{\"months\":12,\"time\":456.789}", "{\"time\":456.789,\"months\":12}" ]

206− (CalendarDiffTime 12 456.789)

207− , ndExample "CalendarDiffDays"

208− [ "{\"months\":12,\"days\":20}", "{\"days\":20,\"months\":12}" ]

209− (CalendarDiffDays 12 20)

210− , example "DayOfWeek" "\"monday\"" Monday

211− ]

212−

213−jsonEncodingExamples :: [Example]

214−jsonEncodingExamples =

215− [

216− -- infinities cannot be recovered, null is decoded as NaN

217− example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)

218− , example "-inf :: Double" "null" (Approx $ -1/0 :: Approx Double)

219− ]

220−

221−jsonDecodingExamples :: [Example]

222−jsonDecodingExamples = [

223− -- Maybe serialising is lossy

224− -- https://github.com/bos/aeson/issues/376

225− MaybeExample "Nothing" "null" (Just Nothing :: Maybe (Maybe Int))

226− , MaybeExample "Just" "1" (Just $ Just 1 :: Maybe (Maybe Int))

227− , MaybeExample "Just Nothing" "null" (Just Nothing :: Maybe (Maybe (Maybe Int)))

228− -- Integral values are truncated, and overflowed

229− -- https://github.com/bos/aeson/issues/317

230− , MaybeExample "Word8 3" "3" (Just 3 :: Maybe Word8)

231− , MaybeExample "Word8 3.00" "3.00" (Just 3 :: Maybe Word8)

232− , MaybeExample "Word8 3.14" "3.14" (Nothing :: Maybe Word8)

233− , MaybeExample "Word8 -1" "-1" (Nothing :: Maybe Word8)

234− , MaybeExample "Word8 300" "300" (Nothing :: Maybe Word8)

235− -- Negative zero year, encoding never produces such:

236− , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))

237− ]

238−

239−data Example where

240− Example

241− :: (Eq a, Show a, ToJSON a, FromJSON a)

242− => String -- name

243− -> [L.ByteString] -- encoded variants

244− -> a -- input

245− -> a -- decoded

246− -> Example -- empty bytestring will fail, any p [] == False

247−

248− MaybeExample

249− :: (Eq a, Show a, FromJSON a)

250− => String -> L.ByteString -> Maybe a -> Example

251−

252−example :: (Eq a, Show a, ToJSON a, FromJSON a)

253− => String -> L.ByteString -> a -> Example

254−example n bs x = Example n [bs] x x

255−

256−-- | Non-deterministic example, input encodes to some of bytestrings.

257−ndExample :: (Eq a, Show a, ToJSON a, FromJSON a)

258− => String -> [L.ByteString] -> a -> Example

259−ndExample n bss x = Example n bss x x

260−

261−

262−data MyEither a b = MyLeft a | MyRight b

263− deriving (Generic, Show, Eq)

264−

265−instance (ToJSON a, ToJSON b) => ToJSON (MyEither a b) where

266− toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

267− toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue }

268−

269−instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where

270− parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

271−

272−assertJsonExample :: Example -> TestTree

273−assertJsonExample (Example name bss val val') = testCase name $ do

274− assertSomeEqual "encode" bss (encode val)

275− assertSomeEqual "encode/via value" bss (encode $ toJSON val)

276− for_ bss $ \bs ->

277− assertEqual "decode" (Just val') (decode bs)

278−assertJsonExample (MaybeExample name bs mval) = testCase name $

279− assertEqual "decode" mval (decode bs)

280−

281−assertJsonEncodingExample :: Example -> TestTree

282−assertJsonEncodingExample (Example name bss val _) = testCase name $ do

283− assertSomeEqual "encode" bss (encode val)

284− assertSomeEqual "encode/via value" bss (encode $ toJSON val)

285−assertJsonEncodingExample (MaybeExample name _ _) = testCase name $

286− assertFailure "cannot encode MaybeExample"

287−

288−assertSomeEqual :: (Eq a, Show a, Foldable f) => String -> f a -> a -> IO ()

289−assertSomeEqual preface expected actual

290− | actual `elem` expected = return ()

291− | otherwise = assertFailure $ preface

292− ++ ": expecting one of " ++ show (toList expected)

293− ++ ", got " ++ show actual

294−

tests/Tests.hs+3−5

@@ -1,10 +1,9 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−

31module Main (main) where

3+import Prelude ()

54import Prelude.Compat

7−import Test.Tasty (defaultMain, testGroup)

6+import Test.Framework (defaultMain)

87import qualified DataFamilies.Properties as DF

98import qualified Properties

109import qualified UnitTests

@@ -12,5 +11,4 @@ import qualified UnitTests

1211main :: IO ()

1312main = do

1413 ioTests <- UnitTests.ioTests

15− let allTests = DF.tests : Properties.tests : UnitTests.tests : ioTests

16− defaultMain (testGroup "tests" allTests)

14+ defaultMain (DF.tests : Properties.tests : UnitTests.tests : ioTests)

tests/Types.hs+5−40

@@ -4,28 +4,22 @@

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GADTs #-}

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE NoImplicitPrelude #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

97{-# LANGUAGE StandaloneDeriving #-}

108

11−module Types (module Types) where

9+module Types where

1210

11+import Prelude ()

1312import Prelude.Compat

1413

15−import Math.NumberTheory.Logarithms (intLog2)

16−import Control.Applicative ((<$>))

1714import Data.Data

1815import Data.Functor.Compose (Compose (..))

1916import Data.Functor.Identity (Identity (..))

20−import Data.Hashable (Hashable (..))

21−import Data.Semigroup (Option)

2217import Data.Text

2318import Data.Time (Day (..), fromGregorian)

2419import GHC.Generics

25−import Test.QuickCheck (Arbitrary (..), Property, counterexample, scale)

20+import Test.QuickCheck (Arbitrary (..), Property, counterexample)

2621import qualified Data.Map as Map

2722import Data.Aeson

28−import Data.Aeson.Types

2923

3024type I = Identity

3125type Compose3 f g h = Compose (Compose f g) h

@@ -106,10 +100,6 @@ deriving instance Data (GADT String)

106100deriving instance Eq (GADT a)

107101deriving instance Show (GADT a)

108102

109−newtype MaybeField = MaybeField { maybeField :: Maybe Int }

110−newtype OptionField = OptionField { optionField :: Option Int }

111− deriving (Eq, Show)

112−

113103deriving instance Generic Foo

114104deriving instance Generic UFoo

115105deriving instance Generic OneConstructor

@@ -119,8 +109,9 @@ deriving instance Generic (Sum4 a b c d)

119109deriving instance Generic (Approx a)

120110deriving instance Generic Nullary

121111deriving instance Generic (SomeType a)

112+#if __GLASGOW_HASKELL__ >= 706

122113deriving instance Generic1 SomeType

123−deriving instance Generic OptionField

114+#endif

124115deriving instance Generic EitherTextInt

125116

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

@@ -142,29 +133,3 @@ instance ToJSON BCEDay where

142133

143134instance FromJSON BCEDay where

144135 parseJSON = fmap BCEDay . parseJSON

145−

146−-- | Scale the size of Arbitrary with ''

147−newtype LogScaled a = LogScaled { getLogScaled :: a }

148− deriving (Eq, Ord, Show)

149−

150−instance Hashable a => Hashable (LogScaled a) where

151− hashWithSalt salt (LogScaled a) = hashWithSalt salt a

152−

153−instance Arbitrary a => Arbitrary (LogScaled a) where

154− arbitrary = LogScaled <$> scale (\x -> intLog2 $ x + 1) arbitrary

155− shrink = fmap LogScaled . shrink . getLogScaled

156−

157−instance ToJSON a => ToJSON (LogScaled a) where

158− toJSON (LogScaled d) = toJSON d

159− toEncoding (LogScaled d) = toEncoding d

160−

161−instance FromJSON a => FromJSON (LogScaled a) where

162− parseJSON = fmap LogScaled . parseJSON

163−

164−instance (ToJSONKey a) => ToJSONKey (LogScaled a) where

165− toJSONKey = contramapToJSONKeyFunction getLogScaled toJSONKey

166− toJSONKeyList = contramapToJSONKeyFunction (fmap getLogScaled) toJSONKeyList

167−

168−instance (FromJSONKey a) => FromJSONKey (LogScaled a) where

169− fromJSONKey = fmap LogScaled fromJSONKey

170− fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])

tests/UnitTests.hs+278−331

@@ -1,84 +1,87 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE GADTs #-}

34{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

55{-# LANGUAGE OverloadedStrings #-}

66{-# LANGUAGE ScopedTypeVariables #-}

77{-# LANGUAGE TemplateHaskell #-}

8−{-# LANGUAGE QuasiQuotes #-}

8+#if __GLASGOW_HASKELL__ >= 708

9+{-# LANGUAGE DataKinds #-}

10+#endif

911

10−-- For Data.Aeson.Types.camelTo

1112{-# OPTIONS_GHC -fno-warn-deprecations #-}

1213

13−#if MIN_VERSION_base(4,9,0)

14−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

15−#endif

16−

1714module UnitTests

1815 (

1916 ioTests

2017 , tests

21− , withEmbeddedJSONTest

2218 ) where

2319

20+import Prelude ()

2421import Prelude.Compat

2522

26−import Control.Monad (forM, forM_)

27−import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)

23+import Control.Applicative (Const(..))

24+import Control.Monad (forM, forM_, unless)

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

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

29−import Data.Aeson.QQ.Simple (aesonQQ)

3027import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)

3128import Data.Aeson.Text (encodeToTextBuilder)

32−import Data.Aeson.Parser

33− ( json, jsonLast, jsonAccum, jsonNoDup

34− , json', jsonLast', jsonAccum', jsonNoDup')

35−import Data.Aeson.Types

36− ( Options(..), Result(Success, Error), ToJSON(..)

37− , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2

38− , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)

39−import Data.Attoparsec.ByteString (Parser, parseOnly)

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

4030import Data.Char (toUpper)

4131import Data.Either.Compat (isLeft, isRight)

32+import Data.Fixed (Pico)

33+import Data.Functor.Compose (Compose(..))

34+import Data.Functor.Identity (Identity(..))

35+import Data.Functor.Product (Product(..))

36+import Data.Functor.Sum (Sum(..))

4237import Data.Hashable (hash)

43−import Data.HashMap.Strict (HashMap)

44−import Data.List (sort, isSuffixOf)

38+import Data.List (sort)

39+import Data.List.NonEmpty (NonEmpty(..))

4540import Data.Maybe (fromMaybe)

46−import Data.Scientific (Scientific, scientific)

41+import Data.Proxy (Proxy(..))

42+import Data.Scientific (Scientific)

43+import Data.Sequence (Seq)

4744import Data.Tagged (Tagged(..))

4845import Data.Text (Text)

49−import Data.Time (UTCTime)

50−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)

46+import Data.Time (UTCTime, fromGregorian)

47+import Data.Time.Format (parseTime)

48+import Data.Time.Locale.Compat (defaultTimeLocale)

49+import Data.Word (Word8)

5150import GHC.Generics (Generic)

5251import Instances ()

53−import Numeric.Natural (Natural)

54−import System.Directory (getDirectoryContents)

52+import System.Directory (doesDirectoryExist, getDirectoryContents)

53+import System.Exit (exitWith, ExitCode(ExitFailure))

54+import System.IO (hPutStrLn, stderr)

5555import System.FilePath ((</>), takeExtension, takeFileName)

56−import Test.Tasty (TestTree, testGroup)

57−import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))

56+import Test.Framework (Test, testGroup)

57+import Test.Framework.Providers.HUnit (testCase)

58+import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)

5859import Text.Printf (printf)

60+import Types (Approx(..), Compose3, Compose3', I)

5961import UnitTests.NullaryConstructors (nullaryConstructors)

60−import qualified Data.ByteString as S

6162import qualified Data.ByteString.Base16.Lazy as LBase16

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

64+import qualified Data.DList as DList

65+import qualified Data.HashMap.Strict as HM

6366import qualified Data.HashSet as HashSet

64−import qualified Data.HashMap.Lazy as HashMap

67+import qualified Data.IntMap as IntMap

68+import qualified Data.IntSet as IntSet

69+import qualified Data.Map as M

70+import qualified Data.Monoid as Monoid

71+import qualified Data.Semigroup as Semigroup

72+import qualified Data.Sequence as Seq

73+import qualified Data.Set as Set

6574import qualified Data.Text.Lazy as LT

6675import qualified Data.Text.Lazy.Builder as TLB

6776import qualified Data.Text.Lazy.Encoding as LT

6877import qualified Data.Text.Lazy.Encoding as TLE

78+import qualified Data.Tree as Tree

79+import qualified Data.UUID.Types as UUID

6980import qualified Data.Vector as Vector

70−import qualified ErrorMessages

71−import qualified SerializationFormatSpec

7281

73−-- Asserts that we can use both modules at once in the test suite.

74−import Data.Aeson.Parser.UnescapeFFI ()

75−import Data.Aeson.Parser.UnescapePure ()

76−

77−tests :: TestTree

82+tests :: Test

7883tests = testGroup "unit" [

79− testGroup "SerializationFormatSpec" SerializationFormatSpec.tests

80− , testGroup "ErrorMessages" ErrorMessages.tests

81− , testGroup "camelCase" [

84+ testGroup "camelCase" [

8285 testCase "camelTo" $ roundTripCamel "aName"

8386 , testCase "camelTo" $ roundTripCamel "another"

8487 , testCase "camelTo" $ roundTripCamel "someOtherName"

@@ -91,41 +94,26 @@ tests = testGroup "unit" [

9194 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")

9295 ]

9396 , testGroup "encoding" [

94− testCase "goodProducer" goodProducer

97+ testCase "goodProducer" $ goodProducer

9598 ]

9699 , testGroup "utctime" [

97− testCase "good" utcTimeGood

98− , testCase "bad" utcTimeBad

100+ testCase "good" $ utcTimeGood

101+ , testCase "bad" $ utcTimeBad

99102 ]

100103 , testGroup "formatError" [

101− testCase "example 1" formatErrorExample

104+ testCase "example 1" $ formatErrorExample

102105 ]

103106 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark

107+ , testGroup "To JSON representation" $ fmap assertJsonEncodingExample jsonEncodingExamples

108+ , testGroup "From JSON representation" $ fmap assertJsonExample jsonDecodingExamples

109+ , testGroup "To/From JSON representation" $ fmap assertJsonExample jsonExamples

110+ , testGroup "JSONPath" $ fmap (testCase "-") jsonPath

104111 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws

105− , testGroup "Object construction" $ fmap (testCase "-") objectConstruction

106112 , testGroup "Issue #351" $ fmap (testCase "-") issue351

107113 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors

108114 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions

109115 , testCase "PR #455" pr455

110116 , testCase "Unescape string (PR #477)" unescapeString

111− , testCase "Show Options" showOptions

112− , testGroup "SingleMaybeField" singleMaybeField

113− , testCase "withEmbeddedJSON" withEmbeddedJSONTest

114− , testCase "SingleFieldCon" singleFieldCon

115− , testGroup "UnknownFields" unknownFields

116− , testGroup "Ordering of object keys" keyOrdering

117− , testCase "Ratio with denominator 0" ratioDenominator0

118− , testCase "Rational parses number" rationalNumber

119− , testCase "Big rational" bigRationalDecoding

120− , testCase "Small rational" smallRationalDecoding

121− , testCase "Big scientific exponent" bigScientificExponent

122− , testCase "Big integer decoding" bigIntegerDecoding

123− , testCase "Big natural decading" bigNaturalDecoding

124− , testCase "Big integer key decoding" bigIntegerKeyDecoding

125− , testGroup "QQ.Simple"

126− [ testCase "example" $

127− assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |]

128− ]

129117 ]

130118

131119roundTripCamel :: String -> Assertion

@@ -142,6 +130,17 @@ camelFrom c s = let (p:ps) = split c s

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

143131

144132

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

134+ deriving (Generic, Show, Eq)

135+

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

137+ toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

138+ toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue }

139+

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

141+ parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

142+

143+

145144data Wibble = Wibble {

146145 wibbleString :: String

147146 , wibbleInt :: Int

@@ -218,20 +217,14 @@ utcTimeGood = do

218217 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11

219218 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12

220219

221− -- leap seconds are included correctly

222− let ts13 = "2015-08-23T23:59:60.128+00" :: LT.Text

223− let (Just (t13 :: UTCTime)) = parseWithAeson ts13

224− assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.128Z") t13

225− let ts14 = "2015-08-23T23:59:60.999999999999+00" :: LT.Text

226− let (Just (t14 :: UTCTime)) = parseWithAeson ts14

227− assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.999999999999Z") t14

228−

229220 where

230221 parseWithRead :: String -> LT.Text -> UTCTime

231222 parseWithRead f s =

232− fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s

223+ case parseTime defaultTimeLocale f . LT.unpack $ s of

224+ Nothing -> error "parseTime input malformed"

225+ Just t -> t

233226 parseWithAeson :: LT.Text -> Maybe UTCTime

234− parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]

227+ parseWithAeson s = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""])

235228

236229-- Test that a few non-timezone qualified timestamp formats get

237230-- rejected if decoding to UTCTime.

@@ -245,10 +238,9 @@ utcTimeBad = do

245238 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given

246239 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits

247240 verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds

248− verifyFailParse "2015-01-03 23:59:61Z" -- exceeds allowed seconds per day

249241 where

250242 verifyFailParse (s :: LT.Text) =

251− let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in

243+ let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""]) in

252244 assertEqual "verify failure" Nothing dec

253245

254246-- Non identifier keys should be escaped & enclosed in brackets

@@ -258,18 +250,6 @@ formatErrorExample =

258250 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

259251 in assertEqual "formatError example" lhs rhs

260252

261−formatPathExample :: Assertion

262−formatPathExample =

263− let rhs = formatPath [Key "x", Index 0]

264− lhs = "$.x[0]"

265− in assertEqual "formatPath example" lhs rhs

266−

267−formatRelativePathExample :: Assertion

268−formatRelativePathExample =

269− let rhs = formatPath [Key "x", Index 0]

270− lhs = ".x[0]"

271− in assertEqual "formatRelativePath example" lhs rhs

272−

273253------------------------------------------------------------------------------

274254-- Comparison (.:?) and (.:!)

275255------------------------------------------------------------------------------

@@ -288,11 +268,11 @@ dotColonMark = [

288268 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)

289269 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)

290270

291− , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2)

271+ , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2)

292272 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)

293273 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)

294274

295− , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3)

275+ , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3)

296276 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)

297277 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)

298278 ]

@@ -300,6 +280,205 @@ dotColonMark = [

300280 ex2 = "{\"value\": 42 }"

301281 ex3 = "{\"value\": null }"

302282

283+------------------------------------------------------------------------------

284+-- These tests assert that the JSON serialization doesn't change by accident.

285+-----------------------------------------------------------------------------

286+

287+data Example where

288+ Example

289+ :: (Eq a, Show a, ToJSON a, FromJSON a)

290+ => String -> L.ByteString -> a -> Example

291+ MaybeExample

292+ :: (Eq a, Show a, FromJSON a)

293+ => String -> L.ByteString -> Maybe a -> Example

294+

295+assertJsonExample :: Example -> Test

296+assertJsonExample (Example name bs val) = testCase name $ do

297+ assertEqual "encode" bs (encode val)

298+ assertEqual "encode/via value" bs (encode $ toJSON val)

299+ assertEqual "decode" (Just val) (decode bs)

300+assertJsonExample (MaybeExample name bs mval) = testCase name $

301+ assertEqual "decode" mval (decode bs)

302+

303+assertJsonEncodingExample :: Example -> Test

304+assertJsonEncodingExample (Example name bs val) = testCase name $ do

305+ assertEqual "encode" bs (encode val)

306+ assertEqual "encode/via value" bs (encode $ toJSON val)

307+assertJsonEncodingExample (MaybeExample name _ _) = testCase name $

308+ assertFailure "cannot encode MaybeExample"

309+

310+jsonEncodingExamples :: [Example]

311+jsonEncodingExamples =

312+ [

313+ -- Maybe serialising is lossy

314+ -- https://github.com/bos/aeson/issues/376

315+ Example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))

316+ -- infinities cannot be recovered, null is decoded as NaN

317+ , Example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)

318+ ]

319+

320+jsonDecodingExamples :: [Example]

321+jsonDecodingExamples = [

322+ -- Maybe serialising is lossy

323+ -- https://github.com/bos/aeson/issues/376

324+ MaybeExample "Nothing" "null" (Just $ Nothing :: Maybe (Maybe Int))

325+ , MaybeExample "Just" "1" (Just $ Just 1 :: Maybe (Maybe Int))

326+ , MaybeExample "Just Nothing" "null" (Just $ Nothing :: Maybe (Maybe (Maybe Int)))

327+ -- Integral values are truncated, and overflowed

328+ -- https://github.com/bos/aeson/issues/317

329+ , MaybeExample "Word8 3" "3" (Just 3 :: Maybe Word8)

330+ , MaybeExample "Word8 3.00" "3.00" (Just 3 :: Maybe Word8)

331+ , MaybeExample "Word8 3.14" "3.14" (Nothing :: Maybe Word8)

332+ , MaybeExample "Word8 -1" "-1" (Nothing :: Maybe Word8)

333+ , MaybeExample "Word8 300" "300" (Nothing :: Maybe Word8)

334+ -- Negative zero year, encoding never produces such:

335+ , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))

336+ ]

337+

338+jsonExamples :: [Example]

339+jsonExamples =

340+ [

341+ Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

342+ , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

343+ , Example "Nothing" "null" (Nothing :: Maybe Int)

344+ , Example "Just" "1" (Just 1 :: Maybe Int)

345+ , Example "Proxy Int" "null" (Proxy :: Proxy Int)

346+ , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

347+#if __GLASGOW_HASKELL__ >= 708

348+ -- Test Tagged instance is polykinded

349+ , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

350+#endif

351+ , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

352+ , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

353+ , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

354+ , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)

355+ , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

356+ , Example "()" "[]" ()

357+

358+ , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

359+ , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int)

360+ , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)

361+ , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)

362+ , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map [Char] Int)

363+ , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)

364+

365+ , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)

366+

367+ , Example "Ordering LT" "\"LT\"" LT

368+ , Example "Ordering EQ" "\"EQ\"" EQ

369+ , Example "Ordering GT" "\"GT\"" GT

370+

371+ , Example "Float" "3.14" (3.14 :: Float)

372+ , Example "Pico" "3.14" (3.14 :: Pico)

373+ , Example "Scientific" "3.14" (3.14 :: Scientific)

374+

375+ , Example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords

376+ 0xc2cc10e1 0x57d64b6f 0x989938d9 0x72112d8c

377+

378+ , Example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)

379+ , Example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])

380+ , Example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)

381+ , Example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)

382+ , Example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)

383+ , Example "Tree Int" "[1,[[2,[[3,[]],[4,[]]]],[5,[]]]]" (let n = Tree.Node in n 1 [n 2 [n 3 [], n 4 []], n 5 []] :: Tree.Tree Int)

384+

385+ -- Three separate cases, as ordering in HashMap is not defined

386+ , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))

387+ , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)

388+ , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)

389+

390+ -- Functors

391+ , Example "Identity Int" "1" (pure 1 :: Identity Int)

392+

393+ , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)

394+ , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)

395+ , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])

396+

397+ , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)

398+ , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

399+ , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])

400+

401+ , Example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)

402+ , Example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)

403+ , Example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)

404+ , Example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)

405+ , Example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)

406+

407+ , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)

408+ , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)

409+ , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)

410+

411+ , Example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)

412+ , Example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)

413+ , Example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)

414+

415+ , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

416+ , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)

417+ , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)

418+ , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)

419+

420+ , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)

421+ , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)

422+ , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)

423+ , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)

424+

425+ , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)

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

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

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

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

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

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

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

433+

434+ , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)

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

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

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

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

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

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

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

442+

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

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

445+

446+ -- newtypes from Monoid/Semigroup

447+ , Example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)

448+ , Example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)

449+ , Example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)

450+ , Example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)

451+ , Example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)

452+ , Example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)

453+ , Example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)

454+ , Example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)

455+ , Example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)

456+ , Example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))

457+ ]

458+

459+

460+

461+------------------------------------------------------------------------------

462+-- These tests check that JSONPath is tracked correctly

463+-----------------------------------------------------------------------------

464+

465+jsonPath :: [Assertion]

466+jsonPath = [

467+ -- issue #356

468+ assertEqual "Either"

469+ (Left "Error in $[1].Left[1]: expected Bool, encountered Number")

470+ (eitherDecode "[1,{\"Left\":[2,3]}]"

471+ :: Either String (Int, Either (Int, Bool) ()))

472+ -- issue #358

473+ , assertEqual "Seq a"

474+ (Left "Error in $[2]: expected Int, encountered Boolean")

475+ (eitherDecode "[0,1,true]" :: Either String (Seq Int))

476+ , assertEqual "Wibble"

477+ (Left "Error in $.wibbleInt: expected Int, encountered Boolean")

478+ (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"

479+ :: Either String Wibble)

480+ ]

481+

303482------------------------------------------------------------------------------

304483-- Check that the hashes of two equal Value are the same

305484------------------------------------------------------------------------------

@@ -312,18 +491,6 @@ hashableLaws = [

312491 a = object ["223" .= False, "807882556" .= True]

313492 b = object ["807882556" .= True, "223" .= False]

314493

315−------------------------------------------------------------------------------

316−-- Check that an alternative way to construct objects works

317−------------------------------------------------------------------------------

318−

319−objectConstruction :: [Assertion]

320−objectConstruction = [

321− assertEqual "Equal objects constructed differently" recommended notRecommended

322− ]

323− where

324− recommended = object ["foo" .= True, "bar" .= (-1 :: Int)]

325− notRecommended = Object (mconcat ["foo" .= True, "bar" .= (-1 :: Int)])

326−

327494-------------------------------------------------------------------------------

328495-- ToJSONKey

329496-------------------------------------------------------------------------------

@@ -384,13 +551,13 @@ issue351 = [

384551-- Comparison between bytestring and text encoders

385552------------------------------------------------------------------------------

386553

387−ioTests :: IO [TestTree]

554+ioTests :: IO [Test]

388555ioTests = do

389556 enc <- encoderComparisonTests

390557 js <- jsonTestSuite

391558 return [enc, js]

392559

393−encoderComparisonTests :: IO TestTree

560+encoderComparisonTests :: IO Test

394561encoderComparisonTests = do

395562 encoderTests <- forM testFiles $ \file0 -> do

396563 let file = "benchmarks/json-data/" ++ file0

@@ -450,7 +617,7 @@ unescapeString = do

450617

451618-- JSONTestSuite

452619

453−jsonTestSuiteTest :: FilePath -> TestTree

620+jsonTestSuiteTest :: FilePath -> Test

454621jsonTestSuiteTest path = testCase fileName $ do

455622 payload <- L.readFile path

456623 let result = eitherDecode payload :: Either String Value

@@ -465,9 +632,15 @@ jsonTestSuiteTest path = testCase fileName $ do

465632-- Build a collection of tests based on the current contents of the

466633-- JSONTestSuite test directories.

467634

468−jsonTestSuite :: IO TestTree

635+jsonTestSuite :: IO Test

469636jsonTestSuite = do

470637 let suitePath = "tests/JSONTestSuite"

638+ exists <- doesDirectoryExist suitePath

639+ unless exists $ do

640+ hPutStrLn stderr $ "git clone https://github.com/nst/JSONTestSuite " ++

641+ suitePath

642+ exitWith (ExitFailure 1)

643+ -- ignore test_transform for now

471644 let suites = ["test_parsing", "test_transform"]

472645 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do

473646 let dir = suitePath </> suite

@@ -528,233 +701,7 @@ pr455 = assertEqual "FooCons FooNil"

528701 foo :: Foo Int

529702 foo = FooCons FooNil

530703

531−showOptions :: Assertion

532−showOptions =

533− assertEqual

534− "Show Options"

535− ( "Options {"

536− ++ "fieldLabelModifier =~ \"exampleField\""

537− ++ ", constructorTagModifier =~ \"ExampleConstructor\""

538− ++ ", allNullaryToStringTag = True"

539− ++ ", omitNothingFields = False"

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

541− ++ ", unwrapUnaryRecords = False"

542− ++ ", tagSingleConstructors = False"

543− ++ ", rejectUnknownFields = False"

544− ++ "}")

545− (show defaultOptions)

546−

547−newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }

548− deriving (Eq, Show, Generic)

549−

550−singleMaybeField :: [TestTree]

551−singleMaybeField = do

552− (gName, gToJSON, gToEncoding, gFromJSON) <-

553− [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))

554− , ("th", toJSON, toEncoding, fromJSON) ]

555− return $

556− testCase gName $ do

557− assertEqual "toJSON" Null (gToJSON v)

558− assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v)

559− assertEqual "fromJSON" (Success v) (gFromJSON Null)

560− where

561− v = SingleMaybeField Nothing

562− opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}

563−

564−

565−newtype EmbeddedJSONTest = EmbeddedJSONTest Int

566− deriving (Eq, Show)

567−

568−instance FromJSON EmbeddedJSONTest where

569− parseJSON =

570− withObject "Object" $ \o ->

571− EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)

572−

573−withEmbeddedJSONTest :: Assertion

574−withEmbeddedJSONTest =

575− assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")

576−

577−-- Regression test for https://github.com/bos/aeson/issues/627

578−newtype SingleFieldCon = SingleFieldCon Int deriving (Eq, Show, Generic)

579−

580−instance FromJSON SingleFieldCon where

581− parseJSON = genericParseJSON defaultOptions{unwrapUnaryRecords=True}

582− -- This option should have no effect on this type

583−

584−singleFieldCon :: Assertion

585−singleFieldCon =

586− assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

587−

588−newtype UnknownFields = UnknownFields { knownField :: Int }

589− deriving (Eq, Show, Generic)

590−newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int }

591− deriving (Eq, Show, Generic)

592−newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int }

593− deriving (Eq, Show, Generic)

594−data UnknownFieldsSum

595− = UnknownFields1 { knownField1 :: Int }

596− | UnknownFields2 { knownField2 :: Int }

597− deriving (Eq, Show, Generic)

598−

599−unknownFields :: [TestTree]

600−unknownFields = concat

601− [ testsUnary

602− "unary-unknown"

603− (object [("knownField", Number 1), ("unknownField", Number 1)])

604− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields)

605− , testsUnary

606− "unary-unknown-tag"

607− (object [("knownField", Number 1), ("tag", String "UnknownFields")])

608− (Error "nknown fields: [\"tag\"]" :: Result UnknownFields)

609− , testsUnaryTag

610− "unary-explicit-tag"

611− (object [("tag", Number 1)])

612− (Success $ UnknownFieldsTag 1)

613− , testsSum

614− "sum-tag"

615− (object [("knownField1", Number 1), ("tag", String "UnknownFields1")])

616− (Success $ UnknownFields1 1)

617− , testsSum

618− "sum-unknown-in-branch"

619− (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")])

620− (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum)

621− , testsSum

622− "sum-unknown"

623− (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")])

624− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum)

625− , testsTagged

626− "unary-tagged"

627− (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")])

628− (Success $ UnknownFieldsUnaryTagged 1)

629− , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests

630− testsTagged

631− "unary-tagged-notag"

632− (object [("knownFieldUnaryTagged", Number 1)])

633− (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged)

634− , testsTagged

635− "unary-tagged-unknown"

636− (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1)

637− , ("tag", String "UnknownFieldsUnaryTagged")])

638− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged)

639− ]

640− where

641− opts = defaultOptions{rejectUnknownFields=True}

642− taggedOpts = opts{tagSingleConstructors=True}

643− assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO ()

644− assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return ()

645− assertApprox expected actual = assertEqual "fromJSON" expected actual

646− testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a)

647− -> String -> Value -> Result a -> [TestTree]

648− testsBase th g name value expected =

649− [ testCase (name ++ "-th") $ assertApprox expected (th value)

650− , testCase (name ++ "-generic") $ assertApprox expected (g value)

651− ]

652− testsUnary :: String -> Value -> Result UnknownFields -> [TestTree]

653− testsUnary = testsBase fromJSON (parse (genericParseJSON opts))

654− testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree]

655− testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts))

656− testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree]

657− testsSum = testsBase fromJSON (parse (genericParseJSON opts))

658− testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree]

659− testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts))

660−

661−testParser :: (Eq a, Show a)

662− => String -> Parser a -> S.ByteString -> Either String a -> TestTree

663−testParser name json_ s expected =

664− testCase name (parseOnly json_ s @?= expected)

665−

666−keyOrdering :: [TestTree]

667−keyOrdering =

668− [ testParser "json" json

669− "{\"k\":true,\"k\":false}" $

670− Right (Object (HashMap.fromList [("k", Bool True)]))

671− , testParser "jsonLast" jsonLast

672− "{\"k\":true,\"k\":false}" $

673− Right (Object (HashMap.fromList [("k", Bool False)]))

674− , testParser "jsonAccum" jsonAccum

675− "{\"k\":true,\"k\":false}" $

676− Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))

677− , testParser "jsonNoDup" jsonNoDup

678− "{\"k\":true,\"k\":false}" $

679− Left "Failed reading: found duplicate key: \"k\""

680−

681− , testParser "json'" json'

682− "{\"k\":true,\"k\":false}" $

683− Right (Object (HashMap.fromList [("k", Bool True)]))

684− , testParser "jsonLast'" jsonLast'

685− "{\"k\":true,\"k\":false}" $

686− Right (Object (HashMap.fromList [("k", Bool False)]))

687− , testParser "jsonAccum'" jsonAccum'

688− "{\"k\":true,\"k\":false}" $

689− Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))

690− , testParser "jsonNoDup'" jsonNoDup'

691− "{\"k\":true,\"k\":false}" $

692− Left "Failed reading: found duplicate key: \"k\""

693− ]

694−

695−ratioDenominator0 :: Assertion

696−ratioDenominator0 =

697− assertEqual "Ratio with denominator 0"

698− (Left "Error in $: Ratio denominator was 0")

699− (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)

700−

701−rationalNumber :: Assertion

702−rationalNumber =

703− assertEqual "Ratio with denominator 0"

704− (Right 1.37)

705− (eitherDecode "1.37" :: Either String Rational)

706−

707−bigRationalDecoding :: Assertion

708−bigRationalDecoding =

709− assertEqual "Decoding an Integer with a large exponent should fail"

710− (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024")

711− ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000")

712−

713−smallRationalDecoding :: Assertion

714−smallRationalDecoding =

715− assertEqual "Decoding an Integer with a large exponent should fail"

716− (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024")

717− ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000")

718−

719−

720−bigScientificExponent :: Assertion

721−bigScientificExponent =

722− assertEqual "Encoding an integral scientific with a large exponent should normalize it"

723− "1.0e2000"

724− (encode (scientific 1 2000 :: Scientific))

725−

726−bigIntegerDecoding :: Assertion

727−bigIntegerDecoding =

728− assertEqual "Decoding an Integer with a large exponent should fail"

729− (Left "Error in $: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024")

730− ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000")

731−

732−bigNaturalDecoding :: Assertion

733−bigNaturalDecoding =

734− assertEqual "Decoding a Natural with a large exponent should fail"

735− (Left "Error in $: parsing Natural failed, found a number with exponent 2000, but it must not be greater than 1024")

736− ((eitherDecode :: L.ByteString -> Either String Natural) "1e2000")

737−

738−bigIntegerKeyDecoding :: Assertion

739−bigIntegerKeyDecoding =

740− assertEqual "Decoding an Integer key with a large exponent should fail"

741− (Left "Error in $['1e2000']: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024")

742− ((eitherDecode :: L.ByteString -> Either String (HashMap Integer Value)) "{ \"1e2000\": null }")

743−

744−bigNaturalKeyDecoding :: Assertion

745−bigNaturalKeyDecoding =

746− assertEqual "Decoding an Integer key with a large exponent should fail"

747− (Left "Error in $['1e2000']: found a number with exponent 2000, but it must not be greater than 1024")

748− ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }")

749−

750704deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord

751705

752706deriveToJSON defaultOptions ''Foo

753707deriveToJSON1 defaultOptions ''Foo

754−

755−deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField

756−

757−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields

758−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag

759−deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged

760−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum

tests/UnitTests/NullaryConstructors.hs+3−8

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

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings #-}

43{-# OPTIONS_GHC -fno-warn-deprecations #-}

@@ -8,16 +7,16 @@ module UnitTests.NullaryConstructors

87 nullaryConstructors

98 ) where

109

10+import Prelude ()

1111import Prelude.Compat

1212

1313import Data.Aeson (decode, eitherDecode, fromEncoding, Value)

1414import Data.Aeson.Internal (IResult (..), iparse)

1515import Data.Aeson.Types (Parser)

1616import Data.ByteString.Builder (toLazyByteString)

17−import Data.Foldable (for_)

1817import Data.Maybe (fromJust)

1918import Encoders

20−import Test.Tasty.HUnit ((@=?), Assertion)

19+import Test.HUnit ((@=?), Assertion)

2120import Types

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

2322

@@ -53,10 +52,6 @@ nullaryConstructors =

5352 -- Make sure that the old `"contents" : []' is still allowed

5453 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

5554 , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

56−

57− , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do

58− Right jkey @=? gNullaryToJSONKey key

59− ISuccess key @=? parse gNullaryFromJSONKey jkey

6055 ]

6156 where

6257 enc = eitherDecode . toLazyByteString . fromEncoding

tests/golden/generic.expecteddeleted−48

@@ -1,48 +0,0 @@

1−OneConstructor

2−Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected Array, but encountered String

3−Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected an empty Array, but encountered an Array of length 1

4−Nullary

5−Error in $: parsing Types.Nullary failed, expected one of the tags ["C1","C2","C3"], but found tag "X"

6−Error in $: parsing Types.Nullary failed, expected String, but encountered Array

7−SomeType (tagged)

8−Error in $.contents: parsing Int failed, expected Number, but encountered Boolean

9−Error in $: parsing Types.SomeType(Unary) failed, key "contents" not found

10−Error in $: parsing Types.SomeType(Record) failed, key "testone" not found

11−Error in $.testone: parsing Double failed, unexpected Boolean

12−Error in $.tag: parsing Types.SomeType failed, expected tag field to be one of ["nullary","unary","product","record","list"], but found tag "X"

13−Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

14−Error in $: parsing Types.SomeType failed, expected Object, but encountered Array

15−SomeType (single-field)

16−Error in $.unary: parsing Int failed, expected Number, but encountered Object

17−Error in $.unary: parsing Int failed, expected Number, but encountered Array

18−Error in $: parsing Types.SomeType failed, expected an Object with a single pair where the tag is one of ["nullary","unary","product","record","list"], but found tag "X"

19−Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs

20−Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs

21−Error in $: parsing Types.SomeType failed, expected Object, but encountered Array

22−Error in $: not enough input. Expecting ':'

23−Error in $: not enough input. Expecting object value

24−Error in $: not enough input. Expecting ',' or '}'

25−SomeType (two-element array)

26−Error in $[1]: parsing Int failed, expected Number, but encountered Boolean

27−Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null

28−Error in $[0]: parsing Types.SomeType failed, expected tag of the 2-element Array to be one of ["nullary","unary","product","record","list"], but found tag "X"

29−Error in $[0]: parsing Types.SomeType failed, tag element is not a String

30−Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0

31−Error in $: parsing Types.SomeType failed, expected Array, but encountered Object

32−Error in $: not enough input. Expecting ',' or ']'

33−Error in $: not enough input. Expecting json list value

34−SomeType (reject unknown fields)

35−Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"]

36−Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

37−Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testtwo","testone","testthree"]

38−Foo (reject unknown fields)

39−Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["tag"]

40−Foo (reject unknown fields, tagged single)

41−Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["unknownField"]

42−EitherTextInt

43−Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"

44−Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array

45−Product2 Int Bool

46−Error in $[1]: expected Bool, but encountered Null

47−Error in $: parsing Types.Product2(Product2) failed, expected an Array of length 2, but encountered an Array of length 0

48−Error in $: parsing Types.Product2(Product2) failed, expected Array, but encountered Object

tests/golden/simple.expecteddeleted−22

@@ -1,22 +0,0 @@

1−Int

2−Error in $: parsing Int failed, expected Number, but encountered String

3−Error in $: parsing Int failed, expected Number, but encountered Array

4−Error in $: parsing Int failed, expected Number, but encountered Object

5−Error in $: parsing Int failed, expected Number, but encountered Null

6−Integer

7−Error in $: parsing Integer failed, unexpected floating number 44.44

8−Natural

9−Error in $: parsing Natural failed, unexpected floating number 44.44

10−Error in $: parsing Natural failed, unexpected negative number -50

11−String

12−Error in $: expected String, but encountered Number

13−Error in $: expected String, but encountered Array

14−Error in $: expected String, but encountered Object

15−Error in $: expected String, but encountered Null

16−HashMap

17−Error in $: parsing HashMap failed, expected Object, but encountered String

18−Error in $: parsing HashMap failed, expected Object, but encountered Array

19−Either

20−Error in $[1].Left[1]: expected Bool, but encountered Number

21−Seq

22−Error in $[2]: parsing Int failed, expected Number, but encountered Boolean

travis/cabal_macros.hdeleted−448

@@ -1,448 +0,0 @@

1−/* DO NOT EDIT: This file is automatically generated by Cabal */

2−

3−/* package aeson-1.4.4.0 */

4−#ifndef VERSION_aeson

5−#define VERSION_aeson "1.4.4.0"

6−#endif /* VERSION_aeson */

7−#ifndef MIN_VERSION_aeson

8−#define MIN_VERSION_aeson(major1,major2,minor) (\

9− (major1) < 1 || \

10− (major1) == 1 && (major2) < 4 || \

11− (major1) == 1 && (major2) == 4 && (minor) <= 4)

12−#endif /* MIN_VERSION_aeson */

13−

14−/* package Diff-0.3.4 */

15−#ifndef VERSION_Diff

16−#define VERSION_Diff "0.3.4"

17−#endif /* VERSION_Diff */

18−#ifndef MIN_VERSION_Diff

19−#define MIN_VERSION_Diff(major1,major2,minor) (\

20− (major1) < 0 || \

21− (major1) == 0 && (major2) < 3 || \

22− (major1) == 0 && (major2) == 3 && (minor) <= 4)

23−#endif /* MIN_VERSION_Diff */

24−

25−/* package QuickCheck-2.13.1 */

26−#ifndef VERSION_QuickCheck

27−#define VERSION_QuickCheck "2.13.1"

28−#endif /* VERSION_QuickCheck */

29−#ifndef MIN_VERSION_QuickCheck

30−#define MIN_VERSION_QuickCheck(major1,major2,minor) (\

31− (major1) < 2 || \

32− (major1) == 2 && (major2) < 13 || \

33− (major1) == 2 && (major2) == 13 && (minor) <= 1)

34−#endif /* MIN_VERSION_QuickCheck */

35−

36−/* package aeson-1.4.4.0 */

37−#ifndef VERSION_aeson

38−#define VERSION_aeson "1.4.4.0"

39−#endif /* VERSION_aeson */

40−#ifndef MIN_VERSION_aeson

41−#define MIN_VERSION_aeson(major1,major2,minor) (\

42− (major1) < 1 || \

43− (major1) == 1 && (major2) < 4 || \

44− (major1) == 1 && (major2) == 4 && (minor) <= 4)

45−#endif /* MIN_VERSION_aeson */

46−

47−/* package attoparsec-0.13.2.2 */

48−#ifndef VERSION_attoparsec

49−#define VERSION_attoparsec "0.13.2.2"

50−#endif /* VERSION_attoparsec */

51−#ifndef MIN_VERSION_attoparsec

52−#define MIN_VERSION_attoparsec(major1,major2,minor) (\

53− (major1) < 0 || \

54− (major1) == 0 && (major2) < 13 || \

55− (major1) == 0 && (major2) == 13 && (minor) <= 2)

56−#endif /* MIN_VERSION_attoparsec */

57−

58−/* package base-4.12.0.0 */

59−#ifndef VERSION_base

60−#define VERSION_base "4.12.0.0"

61−#endif /* VERSION_base */

62−#ifndef MIN_VERSION_base

63−#define MIN_VERSION_base(major1,major2,minor) (\

64− (major1) < 4 || \

65− (major1) == 4 && (major2) < 12 || \

66− (major1) == 4 && (major2) == 12 && (minor) <= 0)

67−#endif /* MIN_VERSION_base */

68−

69−/* package base-compat-0.10.5 */

70−#ifndef VERSION_base_compat

71−#define VERSION_base_compat "0.10.5"

72−#endif /* VERSION_base_compat */

73−#ifndef MIN_VERSION_base_compat

74−#define MIN_VERSION_base_compat(major1,major2,minor) (\

75− (major1) < 0 || \

76− (major1) == 0 && (major2) < 10 || \

77− (major1) == 0 && (major2) == 10 && (minor) <= 5)

78−#endif /* MIN_VERSION_base_compat */

79−

80−/* package base-orphans-0.8.1 */

81−#ifndef VERSION_base_orphans

82−#define VERSION_base_orphans "0.8.1"

83−#endif /* VERSION_base_orphans */

84−#ifndef MIN_VERSION_base_orphans

85−#define MIN_VERSION_base_orphans(major1,major2,minor) (\

86− (major1) < 0 || \

87− (major1) == 0 && (major2) < 8 || \

88− (major1) == 0 && (major2) == 8 && (minor) <= 1)

89−#endif /* MIN_VERSION_base_orphans */

90−

91−/* package base16-bytestring-0.1.1.6 */

92−#ifndef VERSION_base16_bytestring

93−#define VERSION_base16_bytestring "0.1.1.6"

94−#endif /* VERSION_base16_bytestring */

95−#ifndef MIN_VERSION_base16_bytestring

96−#define MIN_VERSION_base16_bytestring(major1,major2,minor) (\

97− (major1) < 0 || \

98− (major1) == 0 && (major2) < 1 || \

99− (major1) == 0 && (major2) == 1 && (minor) <= 1)

100−#endif /* MIN_VERSION_base16_bytestring */

101−

102−/* package bytestring-0.10.8.2 */

103−#ifndef VERSION_bytestring

104−#define VERSION_bytestring "0.10.8.2"

105−#endif /* VERSION_bytestring */

106−#ifndef MIN_VERSION_bytestring

107−#define MIN_VERSION_bytestring(major1,major2,minor) (\

108− (major1) < 0 || \

109− (major1) == 0 && (major2) < 10 || \

110− (major1) == 0 && (major2) == 10 && (minor) <= 8)

111−#endif /* MIN_VERSION_bytestring */

112−

113−/* package containers-0.6.0.1 */

114−#ifndef VERSION_containers

115−#define VERSION_containers "0.6.0.1"

116−#endif /* VERSION_containers */

117−#ifndef MIN_VERSION_containers

118−#define MIN_VERSION_containers(major1,major2,minor) (\

119− (major1) < 0 || \

120− (major1) == 0 && (major2) < 6 || \

121− (major1) == 0 && (major2) == 6 && (minor) <= 0)

122−#endif /* MIN_VERSION_containers */

123−

124−/* package directory-1.3.3.0 */

125−#ifndef VERSION_directory

126−#define VERSION_directory "1.3.3.0"

127−#endif /* VERSION_directory */

128−#ifndef MIN_VERSION_directory

129−#define MIN_VERSION_directory(major1,major2,minor) (\

130− (major1) < 1 || \

131− (major1) == 1 && (major2) < 3 || \

132− (major1) == 1 && (major2) == 3 && (minor) <= 3)

133−#endif /* MIN_VERSION_directory */

134−

135−/* package dlist-0.8.0.6 */

136−#ifndef VERSION_dlist

137−#define VERSION_dlist "0.8.0.6"

138−#endif /* VERSION_dlist */

139−#ifndef MIN_VERSION_dlist

140−#define MIN_VERSION_dlist(major1,major2,minor) (\

141− (major1) < 0 || \

142− (major1) == 0 && (major2) < 8 || \

143− (major1) == 0 && (major2) == 8 && (minor) <= 0)

144−#endif /* MIN_VERSION_dlist */

145−

146−/* package filepath-1.4.2.1 */

147−#ifndef VERSION_filepath

148−#define VERSION_filepath "1.4.2.1"

149−#endif /* VERSION_filepath */

150−#ifndef MIN_VERSION_filepath

151−#define MIN_VERSION_filepath(major1,major2,minor) (\

152− (major1) < 1 || \

153− (major1) == 1 && (major2) < 4 || \

154− (major1) == 1 && (major2) == 4 && (minor) <= 2)

155−#endif /* MIN_VERSION_filepath */

156−

157−/* package generic-deriving-1.12.4 */

158−#ifndef VERSION_generic_deriving

159−#define VERSION_generic_deriving "1.12.4"

160−#endif /* VERSION_generic_deriving */

161−#ifndef MIN_VERSION_generic_deriving

162−#define MIN_VERSION_generic_deriving(major1,major2,minor) (\

163− (major1) < 1 || \

164− (major1) == 1 && (major2) < 12 || \

165− (major1) == 1 && (major2) == 12 && (minor) <= 4)

166−#endif /* MIN_VERSION_generic_deriving */

167−

168−/* package ghc-prim-0.5.3 */

169−#ifndef VERSION_ghc_prim

170−#define VERSION_ghc_prim "0.5.3"

171−#endif /* VERSION_ghc_prim */

172−#ifndef MIN_VERSION_ghc_prim

173−#define MIN_VERSION_ghc_prim(major1,major2,minor) (\

174− (major1) < 0 || \

175− (major1) == 0 && (major2) < 5 || \

176− (major1) == 0 && (major2) == 5 && (minor) <= 3)

177−#endif /* MIN_VERSION_ghc_prim */

178−

179−/* package hashable-1.3.0.0 */

180−#ifndef VERSION_hashable

181−#define VERSION_hashable "1.3.0.0"

182−#endif /* VERSION_hashable */

183−#ifndef MIN_VERSION_hashable

184−#define MIN_VERSION_hashable(major1,major2,minor) (\

185− (major1) < 1 || \

186− (major1) == 1 && (major2) < 3 || \

187− (major1) == 1 && (major2) == 3 && (minor) <= 0)

188−#endif /* MIN_VERSION_hashable */

189−

190−/* package hashable-time-0.2.0.2 */

191−#ifndef VERSION_hashable_time

192−#define VERSION_hashable_time "0.2.0.2"

193−#endif /* VERSION_hashable_time */

194−#ifndef MIN_VERSION_hashable_time

195−#define MIN_VERSION_hashable_time(major1,major2,minor) (\

196− (major1) < 0 || \

197− (major1) == 0 && (major2) < 2 || \

198− (major1) == 0 && (major2) == 2 && (minor) <= 0)

199−#endif /* MIN_VERSION_hashable_time */

200−

201−/* package integer-logarithms-1.0.3 */

202−#ifndef VERSION_integer_logarithms

203−#define VERSION_integer_logarithms "1.0.3"

204−#endif /* VERSION_integer_logarithms */

205−#ifndef MIN_VERSION_integer_logarithms

206−#define MIN_VERSION_integer_logarithms(major1,major2,minor) (\

207− (major1) < 1 || \

208− (major1) == 1 && (major2) < 0 || \

209− (major1) == 1 && (major2) == 0 && (minor) <= 3)

210−#endif /* MIN_VERSION_integer_logarithms */

211−

212−/* package quickcheck-instances-0.3.21 */

213−#ifndef VERSION_quickcheck_instances

214−#define VERSION_quickcheck_instances "0.3.21"

215−#endif /* VERSION_quickcheck_instances */

216−#ifndef MIN_VERSION_quickcheck_instances

217−#define MIN_VERSION_quickcheck_instances(major1,major2,minor) (\

218− (major1) < 0 || \

219− (major1) == 0 && (major2) < 3 || \

220− (major1) == 0 && (major2) == 3 && (minor) <= 21)

221−#endif /* MIN_VERSION_quickcheck_instances */

222−

223−/* package scientific-0.3.6.2 */

224−#ifndef VERSION_scientific

225−#define VERSION_scientific "0.3.6.2"

226−#endif /* VERSION_scientific */

227−#ifndef MIN_VERSION_scientific

228−#define MIN_VERSION_scientific(major1,major2,minor) (\

229− (major1) < 0 || \

230− (major1) == 0 && (major2) < 3 || \

231− (major1) == 0 && (major2) == 3 && (minor) <= 6)

232−#endif /* MIN_VERSION_scientific */

233−

234−/* package tagged-0.8.6 */

235−#ifndef VERSION_tagged

236−#define VERSION_tagged "0.8.6"

237−#endif /* VERSION_tagged */

238−#ifndef MIN_VERSION_tagged

239−#define MIN_VERSION_tagged(major1,major2,minor) (\

240− (major1) < 0 || \

241− (major1) == 0 && (major2) < 8 || \

242− (major1) == 0 && (major2) == 8 && (minor) <= 6)

243−#endif /* MIN_VERSION_tagged */

244−

245−/* package tasty-1.2.3 */

246−#ifndef VERSION_tasty

247−#define VERSION_tasty "1.2.3"

248−#endif /* VERSION_tasty */

249−#ifndef MIN_VERSION_tasty

250−#define MIN_VERSION_tasty(major1,major2,minor) (\

251− (major1) < 1 || \

252− (major1) == 1 && (major2) < 2 || \

253− (major1) == 1 && (major2) == 2 && (minor) <= 3)

254−#endif /* MIN_VERSION_tasty */

255−

256−/* package tasty-golden-2.3.2 */

257−#ifndef VERSION_tasty_golden

258−#define VERSION_tasty_golden "2.3.2"

259−#endif /* VERSION_tasty_golden */

260−#ifndef MIN_VERSION_tasty_golden

261−#define MIN_VERSION_tasty_golden(major1,major2,minor) (\

262− (major1) < 2 || \

263− (major1) == 2 && (major2) < 3 || \

264− (major1) == 2 && (major2) == 3 && (minor) <= 2)

265−#endif /* MIN_VERSION_tasty_golden */

266−

267−/* package tasty-hunit-0.10.0.2 */

268−#ifndef VERSION_tasty_hunit

269−#define VERSION_tasty_hunit "0.10.0.2"

270−#endif /* VERSION_tasty_hunit */

271−#ifndef MIN_VERSION_tasty_hunit

272−#define MIN_VERSION_tasty_hunit(major1,major2,minor) (\

273− (major1) < 0 || \

274− (major1) == 0 && (major2) < 10 || \

275− (major1) == 0 && (major2) == 10 && (minor) <= 0)

276−#endif /* MIN_VERSION_tasty_hunit */

277−

278−/* package tasty-quickcheck-0.10.1 */

279−#ifndef VERSION_tasty_quickcheck

280−#define VERSION_tasty_quickcheck "0.10.1"

281−#endif /* VERSION_tasty_quickcheck */

282−#ifndef MIN_VERSION_tasty_quickcheck

283−#define MIN_VERSION_tasty_quickcheck(major1,major2,minor) (\

284− (major1) < 0 || \

285− (major1) == 0 && (major2) < 10 || \

286− (major1) == 0 && (major2) == 10 && (minor) <= 1)

287−#endif /* MIN_VERSION_tasty_quickcheck */

288−

289−/* package template-haskell-2.14.0.0 */

290−#ifndef VERSION_template_haskell

291−#define VERSION_template_haskell "2.14.0.0"

292−#endif /* VERSION_template_haskell */

293−#ifndef MIN_VERSION_template_haskell

294−#define MIN_VERSION_template_haskell(major1,major2,minor) (\

295− (major1) < 2 || \

296− (major1) == 2 && (major2) < 14 || \

297− (major1) == 2 && (major2) == 14 && (minor) <= 0)

298−#endif /* MIN_VERSION_template_haskell */

299−

300−/* package text-1.2.3.1 */

301−#ifndef VERSION_text

302−#define VERSION_text "1.2.3.1"

303−#endif /* VERSION_text */

304−#ifndef MIN_VERSION_text

305−#define MIN_VERSION_text(major1,major2,minor) (\

306− (major1) < 1 || \

307− (major1) == 1 && (major2) < 2 || \

308− (major1) == 1 && (major2) == 2 && (minor) <= 3)

309−#endif /* MIN_VERSION_text */

310−

311−/* package time-1.8.0.2 */

312−#ifndef VERSION_time

313−#define VERSION_time "1.8.0.2"

314−#endif /* VERSION_time */

315−#ifndef MIN_VERSION_time

316−#define MIN_VERSION_time(major1,major2,minor) (\

317− (major1) < 1 || \

318− (major1) == 1 && (major2) < 8 || \

319− (major1) == 1 && (major2) == 8 && (minor) <= 0)

320−#endif /* MIN_VERSION_time */

321−

322−/* package time-compat-1.9.2.2 */

323−#ifndef VERSION_time_compat

324−#define VERSION_time_compat "1.9.2.2"

325−#endif /* VERSION_time_compat */

326−#ifndef MIN_VERSION_time_compat

327−#define MIN_VERSION_time_compat(major1,major2,minor) (\

328− (major1) < 1 || \

329− (major1) == 1 && (major2) < 9 || \

330− (major1) == 1 && (major2) == 9 && (minor) <= 2)

331−#endif /* MIN_VERSION_time_compat */

332−

333−/* package unordered-containers-0.2.10.0 */

334−#ifndef VERSION_unordered_containers

335−#define VERSION_unordered_containers "0.2.10.0"

336−#endif /* VERSION_unordered_containers */

337−#ifndef MIN_VERSION_unordered_containers

338−#define MIN_VERSION_unordered_containers(major1,major2,minor) (\

339− (major1) < 0 || \

340− (major1) == 0 && (major2) < 2 || \

341− (major1) == 0 && (major2) == 2 && (minor) <= 10)

342−#endif /* MIN_VERSION_unordered_containers */

343−

344−/* package uuid-types-1.0.3 */

345−#ifndef VERSION_uuid_types

346−#define VERSION_uuid_types "1.0.3"

347−#endif /* VERSION_uuid_types */

348−#ifndef MIN_VERSION_uuid_types

349−#define MIN_VERSION_uuid_types(major1,major2,minor) (\

350− (major1) < 1 || \

351− (major1) == 1 && (major2) < 0 || \

352− (major1) == 1 && (major2) == 0 && (minor) <= 3)

353−#endif /* MIN_VERSION_uuid_types */

354−

355−/* package vector-0.12.0.3 */

356−#ifndef VERSION_vector

357−#define VERSION_vector "0.12.0.3"

358−#endif /* VERSION_vector */

359−#ifndef MIN_VERSION_vector

360−#define MIN_VERSION_vector(major1,major2,minor) (\

361− (major1) < 0 || \

362− (major1) == 0 && (major2) < 12 || \

363− (major1) == 0 && (major2) == 12 && (minor) <= 0)

364−#endif /* MIN_VERSION_vector */

365−

366−/* tool gcc-4.2.1 */

367−#ifndef TOOL_VERSION_gcc

368−#define TOOL_VERSION_gcc "4.2.1"

369−#endif /* TOOL_VERSION_gcc */

370−#ifndef MIN_TOOL_VERSION_gcc

371−#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\

372− (major1) < 4 || \

373− (major1) == 4 && (major2) < 2 || \

374− (major1) == 4 && (major2) == 2 && (minor) <= 1)

375−#endif /* MIN_TOOL_VERSION_gcc */

376−

377−/* tool ghc-8.6.5 */

378−#ifndef TOOL_VERSION_ghc

379−#define TOOL_VERSION_ghc "8.6.5"

380−#endif /* TOOL_VERSION_ghc */

381−#ifndef MIN_TOOL_VERSION_ghc

382−#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\

383− (major1) < 8 || \

384− (major1) == 8 && (major2) < 6 || \

385− (major1) == 8 && (major2) == 6 && (minor) <= 5)

386−#endif /* MIN_TOOL_VERSION_ghc */

387−

388−/* tool ghc-pkg-8.6.5 */

389−#ifndef TOOL_VERSION_ghc_pkg

390−#define TOOL_VERSION_ghc_pkg "8.6.5"

391−#endif /* TOOL_VERSION_ghc_pkg */

392−#ifndef MIN_TOOL_VERSION_ghc_pkg

393−#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\

394− (major1) < 8 || \

395− (major1) == 8 && (major2) < 6 || \

396− (major1) == 8 && (major2) == 6 && (minor) <= 5)

397−#endif /* MIN_TOOL_VERSION_ghc_pkg */

398−

399−/* tool haddock-2.22.0 */

400−#ifndef TOOL_VERSION_haddock

401−#define TOOL_VERSION_haddock "2.22.0"

402−#endif /* TOOL_VERSION_haddock */

403−#ifndef MIN_TOOL_VERSION_haddock

404−#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\

405− (major1) < 2 || \

406− (major1) == 2 && (major2) < 22 || \

407− (major1) == 2 && (major2) == 22 && (minor) <= 0)

408−#endif /* MIN_TOOL_VERSION_haddock */

409−

410−/* tool hpc-0.67 */

411−#ifndef TOOL_VERSION_hpc

412−#define TOOL_VERSION_hpc "0.67"

413−#endif /* TOOL_VERSION_hpc */

414−#ifndef MIN_TOOL_VERSION_hpc

415−#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\

416− (major1) < 0 || \

417− (major1) == 0 && (major2) < 67 || \

418− (major1) == 0 && (major2) == 67 && (minor) <= 0)

419−#endif /* MIN_TOOL_VERSION_hpc */

420−

421−/* tool hsc2hs-0.68.5 */

422−#ifndef TOOL_VERSION_hsc2hs

423−#define TOOL_VERSION_hsc2hs "0.68.5"

424−#endif /* TOOL_VERSION_hsc2hs */

425−#ifndef MIN_TOOL_VERSION_hsc2hs

426−#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\

427− (major1) < 0 || \

428− (major1) == 0 && (major2) < 68 || \

429− (major1) == 0 && (major2) == 68 && (minor) <= 5)

430−#endif /* MIN_TOOL_VERSION_hsc2hs */

431−

432−/* tool runghc-8.6.5 */

433−#ifndef TOOL_VERSION_runghc

434−#define TOOL_VERSION_runghc "8.6.5"

435−#endif /* TOOL_VERSION_runghc */

436−#ifndef MIN_TOOL_VERSION_runghc

437−#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\

438− (major1) < 8 || \

439− (major1) == 8 && (major2) < 6 || \

440− (major1) == 8 && (major2) == 6 && (minor) <= 5)

441−#endif /* MIN_TOOL_VERSION_runghc */

442−

443−#ifndef CURRENT_COMPONENT_ID

444−#define CURRENT_COMPONENT_ID "aeson-1.4.4.0-inplace-tests"

445−#endif /* CURRENT_COMPONENT_ID */

446−#ifndef CURRENT_PACKAGE_VERSION

447−#define CURRENT_PACKAGE_VERSION "1.4.4.0"

448−#endif /* CURRENT_PACKAGE_VERSION */

travis/install.sh−11

@@ -7,11 +7,6 @@ echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo

77stack --version

99case $BUILD in

10− hlint)

11− echo "Downloading hlint"

12− curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh > hlint.sh

13− chmod +x hlint.sh

14− ;;

1510 stack)

1611 stack --no-terminal --skip-ghc-check setup

1712 stack --no-terminal --skip-ghc-check test --only-snapshot

@@ -49,10 +44,4 @@ case $BUILD in

4944 cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

5045 fi

5146 ;;

52− cabal2)

53− cabal v2-update -v

54− sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

55−

56− cabal v2-build --only-dependencies --enable-tests --enable-benchmarks --dry

57− ;;

5847esac

travis/script.sh+1−8

@@ -4,7 +4,7 @@ set -ex

55case $BUILD in

66 stack)

7− stack build --test --haddock --no-terminal

7+ stack build --test --haddock

88 ;;

99 cabal)

1010 if [ -f configure.ac ]; then autoreconf -i; fi

@@ -19,11 +19,4 @@ case $BUILD in

1919 SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&

2020 (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

2121 ;;

22− cabal2)

23− cabal v2-build --enable-tests --enable-benchmarks

24− cabal v2-test --enable-tests --enable-benchmarks

25− ;;

26− hlint)

27− make lint

28− ;;

2922esac