master..bbcb3dc · typeable/aeson

git.iko.soy/typeable/aeson

115 files changed+3915−6759

unifiedsplit

.gitignore−6 .hlint.yaml−11 .travis.yml+14−41 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−43 Data/Aeson/Types/Class.hs+6−18 Data/Aeson/Types/FromJSON.hs+438−902 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−99 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+1−186 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+7−10 stack-lts12.yaml−15 stack-lts6.yaml+11 stack-ffi-unescape.yaml → stack-lts7.yaml+3−4 stack-nightly.yaml+3−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+41−208 tests/Functions.hs+1−2 tests/Instances.hs+70−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+134−183 tests/Tests.hs+3−5 tests/Types.hs+6−11 tests/UnitTests.hs+58−325 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

.gitignore−6

@@ -1,11 +1,8 @@

11dist

22dist-newstyle

3−.ghc.environment.*

43.cabal-sandbox/

54cabal.sandbox.config

65.stack-work/

7−.stack-work-bench/

8−*.yaml.lock

107*.o

118*.hi

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

1411.\#*

1512\#*

1613

17−# Emacs backup files

18−*~

19−

2014benchmarks/AesonEncode

2115

2216tests/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+14−41

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

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

6123 compiler: ": #GHC 7.10.3"

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

63−

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

26+ compiler: ": #GHC 7.4.2"

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

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

29+ compiler: ": #GHC 7.6.3"

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

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

6532 compiler: ": #GHC 7.8.4"

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

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

35+ compiler: ": #GHC 7.10.2"

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

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

38+ compiler: ": #GHC 8.0.1"

39+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], 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 ->

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

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

@@ -113,39 +102,15 @@ module Data.Aeson.Types

113102 , listParser

114103

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

105+ , Options(..)

130106 , SumEncoding(..)

131107 , camelTo

132108 , camelTo2

133109 , defaultOptions

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

147111 ) where

148112

113+import Prelude ()

149114import Prelude.Compat

150115

151116import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs)

@@ -157,6 +122,3 @@ import Data.Foldable (toList)

157122foldable :: (Foldable t, ToJSON a) => t a -> Encoding

158123foldable = toEncoding . toList

159124{-# INLINE foldable #-}

160−

161−-- $optionsFields

162−-- The functions here are in fact record fields of the 'Options' type.

Data/Aeson/Types/Class.hs+6−18

@@ -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,15 +69,14 @@ 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

8579 , typeMismatch

86− , unexpected

8780 , parseField

8881 , parseFieldMaybe

8982 , parseFieldMaybe'

@@ -97,13 +90,8 @@ module Data.Aeson.Types.Class

9790 , (.!=)

9891 ) where

9992

93+import Prelude ()

10094

10195import Data.Aeson.Types.FromJSON

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

97+import Data.Aeson.Types.ToJSON

Data/Aeson/Types/FromJSON.hs+438−902

@@ -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,22 +52,20 @@ 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

6262 , typeMismatch

63− , unexpected

6463 , parseField

6564 , parseFieldMaybe

6665 , parseFieldMaybe'

6766 , explicitParseField

6867 , explicitParseFieldMaybe

6968 , explicitParseFieldMaybe'

70− , parseIndexedJSON

7169 -- ** Operators

7270 , (.:)

7371 , (.:?)

@@ -78,16 +76,17 @@ module Data.Aeson.Types.FromJSON

7876 , parseOptionalFieldWith

7977 ) where

8078

79+import Prelude ()

8180import Prelude.Compat

8281

83−import Control.Applicative ((<|>), Const(..), liftA2)

84−import Control.Monad (zipWithM)

82+import Control.Applicative ((<|>), Const(..))

83+import Control.Monad ((<=<), zipWithM)

8584import Data.Aeson.Internal.Functions (mapKey)

86−import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)

8785import Data.Aeson.Types.Generic

8886import Data.Aeson.Types.Internal

87+import Data.Attoparsec.Number (Number(..))

8988import Data.Bits (unsafeShiftR)

90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)

89+import Data.Fixed (Fixed, HasResolution)

9190import Data.Functor.Compose (Compose(..))

9291import Data.Functor.Identity (Identity(..))

9392import Data.Functor.Product (Product(..))

@@ -96,31 +95,26 @@ import Data.Hashable (Hashable(..))

9695import Data.Int (Int16, Int32, Int64, Int8)

9796import Data.List.NonEmpty (NonEmpty(..))

9897import Data.Maybe (fromMaybe)

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

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

10099import Data.Proxy (Proxy(..))

101100import Data.Ratio ((%), Ratio)

102−import Data.Scientific (Scientific, base10Exponent)

101+import Data.Scientific (Scientific)

103102import Data.Tagged (Tagged(..))

104103import 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)

104+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

105+import Data.Time.Format (parseTime)

106+import Data.Time.Locale.Compat (defaultTimeLocale)

110107import Data.Traversable as Tr (sequence)

111108import Data.Vector (Vector)

112109import Data.Version (Version, parseVersion)

113−import Data.Void (Void)

114110import Data.Word (Word16, Word32, Word64, Word8)

115111import Foreign.Storable (Storable)

116−import Foreign.C.Types (CTime (..))

117112import GHC.Generics

118113import Numeric.Natural (Natural)

119114import Text.ParserCombinators.ReadP (readP_to_S)

120115import Unsafe.Coerce (unsafeCoerce)

121116import qualified Data.Aeson.Parser.Time as Time

122117import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

123−import qualified Data.ByteString.Lazy as L

124118import qualified Data.DList as DList

125119import qualified Data.HashMap.Strict as H

126120import qualified Data.HashSet as HashSet

@@ -143,20 +137,18 @@ import qualified Data.Vector.Primitive as VP

143137import qualified Data.Vector.Storable as VS

144138import qualified Data.Vector.Unboxed as VU

145139

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

140+#ifndef HAS_COERCIBLE

141+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)

154142#endif

155−import qualified Data.Primitive.PrimArray as PM

156−#endif

157−

158143

144+#if HAS_COERCIBLE

159145import Data.Coerce (Coercible, coerce)

146+coerce' :: Coercible a b => a -> b

147+coerce' = coerce

148+#else

149+coerce' :: a -> b

150+coerce' = unsafeCoerce

151+#endif

160152

161153parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

162154parseIndexedJSON p idx value = p value <?> Index idx

@@ -165,7 +157,7 @@ parseIndexedJSON p idx value = p value <?> Index idx

165157parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)

166158parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx

167159 where

168− p = withArray "(k, v)" $ \ab ->

160+ p = withArray "(k,v)" $ \ab ->

169161 let n = V.length ab

170162 in if n == 2

171163 then (,) <$> parseJSONElemAtIndex keyParser 0 ab

@@ -177,34 +169,43 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx

177169parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a

178170parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx

179171

172+scientificToNumber :: Scientific -> Number

173+scientificToNumber s

174+ | e < 0 = D $ Scientific.toRealFloat s

175+ | otherwise = I $ c * 10 ^ e

176+ where

177+ e = Scientific.base10Exponent s

178+ c = Scientific.coefficient s

179+{-# INLINE scientificToNumber #-}

180+

180181parseRealFloat :: 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)

182+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s

183+parseRealFloat _ Null = pure (0/0)

184+parseRealFloat expected v = typeMismatch expected v

184185{-# INLINE parseRealFloat #-}

185186

186−parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a

187−parseIntegralFromScientific s =

187+parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a

188+parseIntegralFromScientific expected s =

188189 case Scientific.floatingOrInteger s :: Either Double a of

189190 Right x -> pure x

190− Left _ -> fail $ "unexpected floating number " ++ show s

191+ Left _ -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s

191192{-# INLINE parseIntegralFromScientific #-}

192193

193194parseIntegral :: Integral a => String -> Value -> Parser a

194−parseIntegral name =

195− prependContext name . withBoundedScientific' parseIntegralFromScientific

195+parseIntegral expected =

196+ withScientific expected $ parseIntegralFromScientific expected

196197{-# INLINE parseIntegral #-}

197198

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)

199+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a

200+parseBoundedIntegralFromScientific expected s = maybe

201+ (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)

201202 pure

202203 (Scientific.toBoundedInteger s)

203204{-# INLINE parseBoundedIntegralFromScientific #-}

204205

205206parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a

206−parseBoundedIntegral name =

207− prependContext name . withScientific' parseBoundedIntegralFromScientific

207+parseBoundedIntegral expected =

208+ withScientific expected $ parseBoundedIntegralFromScientific expected

208209{-# INLINE parseBoundedIntegral #-}

209210

210211parseScientificText :: Text -> Parser Scientific

@@ -214,20 +215,13 @@ parseScientificText

214215 . T.encodeUtf8

215216

216217parseIntegralText :: 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)

218+parseIntegralText expected t =

219+ parseScientificText t >>= parseIntegralFromScientific expected

225220{-# INLINE parseIntegralText #-}

226221

227222parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a

228−parseBoundedIntegralText name t =

229− prependContext name $

230− parseScientificText t >>= parseBoundedIntegralFromScientific

223+parseBoundedIntegralText expected t =

224+ parseScientificText t >>= parseBoundedIntegralFromScientific expected

231225

232226parseOptionalFieldWith :: (Value -> Parser (Maybe a))

233227 -> Object -> Text -> Parser (Maybe a)

@@ -287,21 +281,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

287281--

288282-- The basic ways to signal a failed conversion are as follows:

289283--

290−-- * 'fail' yields a custom error message: it is the recommended way of

291−-- reporting a failure;

284+-- * 'empty' and 'mzero' work, but are terse and uninformative

292285--

293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:

294−-- use it when the error is meant to be caught by some @('<|>')@;

286+-- * 'fail' yields a custom error message

295287--

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.

288+-- * 'typeMismatch' produces an informative message for cases when the

289+-- value encountered is not of the expected type

300290--

301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's

302−-- error messages.

303−--

304−-- An example type and instance using 'typeMismatch' and 'prependFailure':

291+-- An example type and instance:

305292--

306293-- @

307294-- \-- Allow ourselves to write 'Text' literals.

@@ -309,30 +296,15 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

309296--

310297-- data Coord = Coord { x :: Double, y :: Double }

311298--

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:

299+-- instance FromJSON Coord where

300+-- parseJSON ('Object' v) = Coord '<$>'

301+-- v '.:' \"x\" '<*>'

302+-- v '.:' \"y\"

330303--

331−-- @

332−-- instance 'FromJSON' Coord where

333−-- 'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord

334−-- '<$>' v '.:' \"x\"

335−-- '<*>' v '.:' \"y\"

304+-- \-- We do not expect a non-'Object' value here.

305+-- \-- We could use 'mzero' to fail, but 'typeMismatch'

306+-- \-- gives a much more informative error message.

307+-- parseJSON invalid = 'typeMismatch' \"Coord\" invalid

336308-- @

337309--

338310-- Instead of manually writing your 'FromJSON' instance, there are two options

@@ -340,7 +312,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

340312--

341313-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

342314-- instance at compile time. The generated instance is optimized for your type

343−-- so it will probably be more efficient than the following option.

315+-- so will probably be more efficient than the following two options:

344316--

345317-- * The compiler can provide a default generic implementation for

346318-- 'parseJSON'.

@@ -358,21 +330,18 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

358330--

359331-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'

360332--

361−-- instance 'FromJSON' Coord

333+-- instance FromJSON Coord

362334-- @

363335--

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:

336+-- If @DefaultSignatures@ doesn't give exactly the results you want,

337+-- you can customize the generic decoding with only a tiny amount of

338+-- effort, using 'genericParseJSON' with your preferred 'Options':

367339--

368340-- @

369−-- customOptions = 'defaultOptions'

370−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

371−-- }

372−--

373−-- instance 'FromJSON' Coord where

374−-- 'parseJSON' = 'genericParseJSON' customOptions

341+-- instance FromJSON Coord where

342+-- parseJSON = 'genericParseJSON' 'defaultOptions'

375343-- @

344+

376345class FromJSON a where

377346 parseJSON :: Value -> Parser a

378347

@@ -380,11 +349,13 @@ class FromJSON a where

380349 parseJSON = genericParseJSON defaultOptions

381350

382351 parseJSONList :: Value -> Parser [a]

383− parseJSONList = withArray "[]" $ \a ->

384− zipWithM (parseIndexedJSON parseJSON) [0..]

352+ parseJSONList (Array a)

353+ = zipWithM (parseIndexedJSON parseJSON) [0..]

385354 . V.toList

386355 $ a

387356

357+ parseJSONList v = typeMismatch "[a]" v

358+

388359-------------------------------------------------------------------------------

389360-- Classes and types for map keys

390361-------------------------------------------------------------------------------

@@ -396,16 +367,6 @@ class FromJSON a where

396367-- > newtype SomeId = SomeId { getSomeId :: Text }

397368-- > deriving (Eq,Ord,Hashable,FromJSONKey)

398369--

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

409370class FromJSONKey a where

410371 -- | Strategy for parsing the key of a map-like container.

411372 fromJSONKey :: FromJSONKeyFunction a

@@ -428,7 +389,11 @@ class FromJSONKey a where

428389-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

429390-- can be inspected, but cannot be constructed.

430391data CoerceText a where

392+#if HAS_COERCIBLE

431393 CoerceText :: Coercible Text a => CoerceText a

394+#else

395+ CoerceText :: CoerceText a

396+#endif

432397

433398-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

434399-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

@@ -448,7 +413,7 @@ data FromJSONKeyFunction a

448413

449414-- | Only law abiding up to interpretation

450415instance Functor FromJSONKeyFunction where

451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)

416+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

452417 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

453418 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

454419 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

@@ -462,7 +427,9 @@ instance Functor FromJSONKeyFunction where

462427--

463428-- On pre GHC 7.8 this is unconstrainted function.

464429fromJSONKeyCoerce ::

430+#if HAS_COERCIBLE

465431 Coercible Text a =>

432+#endif

466433 FromJSONKeyFunction a

467434fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

468435

@@ -470,91 +437,60 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

470437--

471438-- See note on 'fromJSONKeyCoerce'.

472439coerceFromJSONKeyFunction ::

440+#if HAS_COERCIBLE

473441 Coercible a b =>

442+#endif

474443 FromJSONKeyFunction a -> FromJSONKeyFunction b

444+#if HAS_COERCIBLE

475445coerceFromJSONKeyFunction = coerce

446+#else

447+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

448+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

449+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

450+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

451+#endif

476452

477453{-# RULES

478454 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

479455 fmap id x = x

480456 #-}

457+#if HAS_COERCIBLE

481458{-# RULES

482459 "FromJSONKeyCoerce: fmap coerce" forall x .

483460 fmap coerce x = coerceFromJSONKeyFunction x

484461 #-}

462+#endif

485463

486464-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

487465mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

488466mapFromJSONKeyFunction = fmap

489467

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−

519468-------------------------------------------------------------------------------

520469-- Functions needed for documentation

521470-------------------------------------------------------------------------------

522471

523472-- | Fail parsing due to a type mismatch, with a descriptive message.

524473--

525−-- The following wrappers should generally be prefered:

526−-- 'withObject', 'withArray', 'withText', 'withBool'.

527−--

528−-- ==== Error message example

474+-- Example usage:

529475--

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\"@).

476+-- @

477+-- instance FromJSON Coord where

478+-- parseJSON ('Object' v) = {- type matches, life is good -}

479+-- parseJSON wat = 'typeMismatch' \"Coord\" wat

480+-- @

481+typeMismatch :: String -- ^ The name of the type you are trying to parse.

535482 -> Value -- ^ The actual value encountered.

536483 -> Parser a

537484typeMismatch 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"

485+ fail $ "expected " ++ expected ++ ", encountered " ++ name

486+ where

487+ name = case actual of

488+ Object _ -> "Object"

489+ Array _ -> "Array"

490+ String _ -> "String"

491+ Number _ -> "Number"

492+ Bool _ -> "Boolean"

493+ Null -> "Null"

558494

559495-------------------------------------------------------------------------------

560496-- Lifings of FromJSON and ToJSON to unary and binary type constructors

@@ -567,7 +503,7 @@ typeOf v = case v of

567503--

568504-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an

569505-- instance at compile time. The generated instance is optimized for your type

570−-- so it will probably be more efficient than the following option.

506+-- so will probably be more efficient than the following two options:

571507--

572508-- * The compiler can provide a default generic implementation for

573509-- 'liftParseJSON'.

@@ -585,20 +521,16 @@ typeOf v = case v of

585521--

586522-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'

587523--

588−-- instance 'FromJSON' a => 'FromJSON1' (Pair a)

524+-- instance FromJSON a => FromJSON1 (Pair a)

589525-- @

590526--

591−-- If the default implementation doesn't give exactly the results you want,

527+-- If @DefaultSignatures@ doesn't give exactly the results you want,

592528-- you can customize the generic decoding with only a tiny amount of

593529-- effort, using 'genericLiftParseJSON' with your preferred 'Options':

594530--

595531-- @

596−-- customOptions = 'defaultOptions'

597−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'

598−-- }

599−--

600−-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where

601−-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions

532+-- instance FromJSON a => FromJSON1 (Pair a) where

533+-- liftParseJSON = 'genericLiftParseJSON' 'defaultOptions'

602534-- @

603535class FromJSON1 f where

604536 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)

@@ -635,8 +567,9 @@ class FromJSON2 f where

635567 -> (Value -> Parser b)

636568 -> (Value -> Parser [b])

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

570+ liftParseJSONList2 fa ga fb gb v = case v of

571+ Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)

572+ _ -> typeMismatch "[a]" v

640573

641574-- | Lift the standard 'parseJSON' function through the type constructor.

642575parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)

@@ -650,7 +583,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList

650583-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.

651584listParser :: (Value -> Parser a) -> Value -> Parser [a]

652585listParser f (Array xs) = fmap V.toList (V.mapM f xs)

653−listParser _ v = typeMismatch "Array" v

586+listParser _ v = typeMismatch "[a]" v

654587{-# INLINE listParser #-}

655588

656589-------------------------------------------------------------------------------

@@ -668,139 +601,48 @@ instance (FromJSON a) => FromJSON [a] where

668601-- Functions

669602-------------------------------------------------------------------------------

670603

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"

604+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@

605+-- and fails using @'typeMismatch' expected@ otherwise.

686606withObject :: String -> (Object -> Parser a) -> Value -> Parser a

687−withObject _ f (Object obj) = f obj

688−withObject name _ v = prependContext name (typeMismatch "Object" v)

607+withObject _ f (Object obj) = f obj

608+withObject expected _ v = typeMismatch expected v

689609{-# INLINE withObject #-}

690610

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"

611+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@

612+-- and fails using @'typeMismatch' expected@ otherwise.

698613withText :: String -> (Text -> Parser a) -> Value -> Parser a

699−withText _ f (String txt) = f txt

700−withText name _ v = prependContext name (typeMismatch "String" v)

614+withText _ f (String txt) = f txt

615+withText expected _ v = typeMismatch expected v

701616{-# INLINE withText #-}

702617

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"

618+-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@

619+-- and fails using @'typeMismatch' expected@ otherwise.

710620withArray :: String -> (Array -> Parser a) -> Value -> Parser a

711−withArray _ f (Array arr) = f arr

712−withArray name _ v = prependContext name (typeMismatch "Array" v)

621+withArray _ f (Array arr) = f arr

622+withArray expected _ v = typeMismatch expected v

713623{-# INLINE withArray #-}

714624

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"

625+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.

626+-- and fails using @'typeMismatch' expected@ otherwise.

627+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a

628+withNumber expected f = withScientific expected (f . scientificToNumber)

629+{-# INLINE withNumber #-}

630+{-# DEPRECATED withNumber "Use withScientific instead" #-}

631+

632+-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.

633+-- and fails using @'typeMismatch' expected@ otherwise.

728634withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a

729−withScientific _ f (Number scientific) = f scientific

730−withScientific name _ v = prependContext name (typeMismatch "Number" v)

635+withScientific _ f (Number scientific) = f scientific

636+withScientific expected _ v = typeMismatch expected v

731637{-# INLINE withScientific #-}

732638

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"

639+-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@

640+-- and fails using @'typeMismatch' expected@ otherwise.

789641withBool :: String -> (Bool -> Parser a) -> Value -> Parser a

790−withBool _ f (Bool arr) = f arr

791−withBool name _ v = prependContext name (typeMismatch "Boolean" v)

642+withBool _ f (Bool arr) = f arr

643+withBool expected _ v = typeMismatch expected v

792644{-# INLINE withBool #-}

793645

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−

804646-- | Convert a value from JSON, failing if the types do not match.

805647fromJSON :: (FromJSON a) => Value -> Result a

806648fromJSON = parse parseJSON

@@ -863,7 +705,7 @@ parseFieldMaybe' = (.:!)

863705-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

864706explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

865707explicitParseField p obj key = case H.lookup key obj of

866− Nothing -> fail $ "key " ++ show key ++ " not found"

708+ Nothing -> fail $ "key " ++ show key ++ " not present"

867709 Just v -> p v <?> Key key

868710{-# INLINE explicitParseField #-}

869711

@@ -903,47 +745,11 @@ pmval .!= val = fromMaybe val <$> pmval

903745-- Generic parseJSON

904746-------------------------------------------------------------------------------

905747

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−

911748instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where

912749 -- Meta-information, which is not handled elsewhere, is just added to the

913750 -- parsed value:

914751 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs

915752

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−

947753instance (FromJSON a) => GFromJSON arity (K1 i a) where

948754 -- Constant values are decoded using their FromJSON instance:

949755 gParseJSON _opts _ = fmap K1 . parseJSON

@@ -958,499 +764,326 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where

958764 -- FromJSON1 instance:

959765 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl

960766

767+instance GFromJSON arity U1 where

768+ -- Empty constructors are expected to be encoded as an empty array:

769+ gParseJSON _opts _ v

770+ | isEmptyArray v = pure U1

771+ | otherwise = typeMismatch "unit constructor (U1)" v

772+

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

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

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

776+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs

777+

778+instance ( FromProduct arity a, FromProduct arity b

779+ , ProductSize a, ProductSize b

780+ ) => GFromJSON arity (a :*: b) where

781+ -- Products are expected to be encoded to an array. Here we check whether we

782+ -- got an array of the same size as the product, then parse each of the

783+ -- product's elements using parseProduct:

784+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->

785+ let lenArray = V.length arr

786+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

787+ productSize in

788+ if lenArray == lenProduct

789+ then parseProduct opts fargs arr 0 lenProduct

790+ else fail $ "When expecting a product of " ++ show lenProduct ++

791+ " values, encountered an Array of " ++ show lenArray ++

792+ " elements instead"

793+

794+instance ( AllNullary (a :+: b) allNullary

795+ , ParseSum arity (a :+: b) allNullary

796+ ) => GFromJSON arity (a :+: b) where

797+ -- If all constructors of a sum datatype are nullary and the

798+ -- 'allNullaryToStringTag' option is set they are expected to be

799+ -- encoded as strings. This distinction is made by 'parseSum':

800+ gParseJSON opts fargs =

801+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->

802+ Parser ((a :+: b) d))

803+ . parseSum opts fargs

804+

961805instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where

962806 -- If an occurrence of the last type parameter is nested inside two

963807 -- composed types, it is decoded by using the outermost type's FromJSON1

964808 -- instance to generically decode the innermost type:

965809 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

810+ let gpj = gParseJSON opts fargs in

811+ fmap Comp1 . liftParseJSON gpj (listParser gpj)

1013812

1014813--------------------------------------------------------------------------------

1015814

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

816+ parseSum :: Options -> FromArgs arity a

817+ -> Value -> Tagged allNullary (Parser (f a))

818+

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

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

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

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

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

824+ parseSum opts fargs

825+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

826+ | otherwise = Tagged . parseNonAllNullarySum opts fargs

827+

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

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

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

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

832+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

1037833

1038834--------------------------------------------------------------------------------

1039835

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

836+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)

837+parseAllNullarySum opts = withText "Text" $ \key ->

838+ maybe (notFound key) return $

839+ parseSumFromString opts key

1062840

1063841class SumFromString f where

1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)

842+ parseSumFromString :: Options -> Text -> Maybe (f a)

1065843

1066844instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

1067845 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

1068846 (R1 <$> parseSumFromString opts key)

1069847

1070848instance (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

849+ parseSumFromString opts key | key == name = Just $ M1 U1

850+ | otherwise = Nothing

851+ where

852+ name = pack $ constructorTagModifier opts $

853+ conName (undefined :: t c U1 p)

1111854

1112855--------------------------------------------------------------------------------

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 :* _) =

856+

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

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

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

860+ ) => Options -> FromArgs arity c

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

862+parseNonAllNullarySum opts fargs =

1121863 case sumEncoding opts of

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

865+ withObject "Object" $ \obj -> do

866+ tag <- obj .: pack tagFieldName

867+ fromMaybe (notFound tag) $

868+ parseFromTaggedObject opts fargs contentsFieldName obj tag

1133869

1134870 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

871+ withObject "Object" $ \obj ->

872+ case H.toList obj of

873+ [pair@(tag, _)] -> fromMaybe (notFound tag) $

874+ parsePair opts fargs pair

875+ _ -> fail "Object doesn't have a single field"

1145876

1146877 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

878+ withArray "Array" $ \arr ->

879+ if V.length arr == 2

880+ then case V.unsafeIndex arr 0 of

881+ String tag -> fromMaybe (notFound tag) $

882+ parsePair opts fargs (tag, V.unsafeIndex arr 1)

883+ _ -> fail "First element is not a String"

884+ else fail "Array doesn't have 2 elements"

1161885

1162− UntaggedValue -> parseUntaggedValue p

1163− where

1164− failWith_ = failWithCTags tname (constructorTagModifier opts)

886+ UntaggedValue -> parseUntaggedValue opts fargs

1165887

1166888--------------------------------------------------------------------------------

1167889

1168890class 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))

891+ parseFromTaggedObject :: Options -> FromArgs arity a

892+ -> String -> Object

893+ -> Text -> Maybe (Parser (f a))

1175894

1176895instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>

1177896 FromTaggedObject arity (a :+: b) where

1178− parseFromTaggedObject p obj =

1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>

1180− (fmap R1 <$> parseFromTaggedObject p obj)

897+ parseFromTaggedObject opts fargs contentsFieldName obj tag =

898+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>

899+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)

1181900

1182−instance ( IsRecord f isRecord

1183− , FromTaggedObject' arity f isRecord

901+instance ( FromTaggedObject' arity f

1184902 , Constructor c

1185903 ) => 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)

904+ parseFromTaggedObject opts fargs contentsFieldName obj tag

905+ | tag == name = Just $ M1 <$> parseFromTaggedObject'

906+ opts fargs contentsFieldName obj

907+ | otherwise = Nothing

908+ where

909+ name = pack $ constructorTagModifier opts $

910+ conName (undefined :: t c f p)

1195911

1196912--------------------------------------------------------------------------------

1197913

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

914+class FromTaggedObject' arity f where

915+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String

916+ -> Object -> Parser (f a)

917+

918+class FromTaggedObject'' arity f isRecord where

919+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String

920+ -> Object -> Tagged isRecord (Parser (f a))

921+

922+instance ( IsRecord f isRecord

923+ , FromTaggedObject'' arity f isRecord

924+ ) => FromTaggedObject' arity f where

925+ parseFromTaggedObject' opts fargs contentsFieldName =

926+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .

927+ parseFromTaggedObject'' opts fargs contentsFieldName

928+

929+instance (FromRecord arity f) => FromTaggedObject'' arity f True where

930+ parseFromTaggedObject'' opts fargs _ =

931+ Tagged . parseRecord opts fargs Nothing

932+

933+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where

934+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .

935+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))

1216936

1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where

1218− -- Nullary constructors don't need a contents field

1219− parseFromTaggedObject' _ _ = Tagged (pure U1)

937+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where

938+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)

1220939

1221940--------------------------------------------------------------------------------

1222941

1223−-- | Constructors need to be decoded differently depending on whether they're

1224−-- a record or not. This distinction is made by 'ConsParseJSON'.

1225942class ConsFromJSON arity f where

1226− consParseJSON

1227− :: ConName :* TypeName :* Options :* FromArgs arity a

1228− -> Value -> Parser (f a)

943+ consParseJSON :: Options -> FromArgs arity a

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

1229945

1230946class ConsFromJSON' arity f isRecord where

1231− consParseJSON'

1232− :: ConName :* TypeName :* Options :* FromArgs arity a

1233− -> Value -> Tagged isRecord (Parser (f a))

947+ consParseJSON' :: Options -> FromArgs arity a

948+ -> Maybe Text -- ^ A dummy label

949+ -- (Nothing to use proper label)

950+ -> Value -> Tagged isRecord (Parser (f a))

1234951

1235952instance ( IsRecord f isRecord

1236953 , ConsFromJSON' arity f isRecord

1237954 ) => ConsFromJSON arity f where

1238− consParseJSON p =

1239− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1240− . consParseJSON' p

955+ consParseJSON opts fargs v = let

956+ (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of

957+ -- use a dummy object with a dummy label

958+ (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")

959+ _ ->(v,Nothing)

960+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

961+ $ consParseJSON' opts fargs lab v2

1241962

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

1252963

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)

964+instance (FromRecord arity f) => ConsFromJSON' arity f True where

965+ consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"

966+ (parseRecord opts fargs mlab)

1265967

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

1270−

1271−instance (ProductFromJSON arity f, ProductSize f

1272− ) => ConsFromJSON' arity f False where

1273− consParseJSON' p = Tagged . productParseJSON0 p

968+instance (GFromJSON arity f) => ConsFromJSON' arity f False where

969+ consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs

1274970

1275971--------------------------------------------------------------------------------

1276972

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

973+class FromRecord arity f where

974+ parseRecord :: Options -> FromArgs arity a

975+ -> Maybe Text -- ^ A dummy label

976+ -- (Nothing to use proper label)

977+ -> Object -> Parser (f a)

1287978

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

979+instance ( FromRecord arity a

980+ , FromRecord arity b

981+ ) => FromRecord arity (a :*: b) where

982+ parseRecord opts fargs _ obj =

983+ (:*:) <$> parseRecord opts fargs Nothing obj

984+ <*> parseRecord opts fargs Nothing obj

1322985

1323986instance 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)

987+ FromRecord arity (S1 s a) where

988+ parseRecord opts fargs lab =

989+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)

990+ where

991+ label = fromMaybe defLabel lab

992+ defLabel = pack . fieldLabelModifier opts $

993+ selName (undefined :: t s a p)

1338994

1339−-- Parse an Option like a Maybe.

1340995instance 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))

996+ FromRecord arity (S1 s (K1 i (Maybe a))) where

997+ parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab

998+ parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label

999+ where

1000+ label = fieldLabelModifier opts $

1001+ selName (undefined :: t s (K1 i (Maybe a)) p)

13461002

13471003--------------------------------------------------------------------------------

13481004

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

1005+class FromProduct arity f where

1006+ parseProduct :: Options -> FromArgs arity a

13711007 -> Array -> Int -> Int

13721008 -> Parser (f a)

13731009

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

1010+instance ( FromProduct arity a

1011+ , FromProduct arity b

1012+ ) => FromProduct arity (a :*: b) where

1013+ parseProduct opts fargs arr ix len =

1014+ (:*:) <$> parseProduct opts fargs arr ix lenL

1015+ <*> parseProduct opts fargs arr ixR lenR

13801016 where

13811017 lenL = len `unsafeShiftR` 1

13821018 ixR = ix + lenL

13831019 lenR = len - lenL

13841020

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

1021+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where

1022+ parseProduct opts fargs arr ix _ =

1023+ gParseJSON opts fargs $ V.unsafeIndex arr ix

13881024

13891025--------------------------------------------------------------------------------

13901026

13911027class 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))

1028+ parsePair :: Options -> FromArgs arity a

1029+ -> Pair -> Maybe (Parser (f a))

13961030

13971031instance ( FromPair arity a

13981032 , FromPair arity b

13991033 ) => FromPair arity (a :+: b) where

1400− parsePair p pair =

1401− (fmap L1 <$> parsePair p pair) <|>

1402− (fmap R1 <$> parsePair p pair)

1034+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>

1035+ (fmap R1 <$> parsePair opts fargs pair)

14031036

14041037instance ( Constructor c

1038+ , GFromJSON arity a

14051039 , ConsFromJSON arity a

14061040 ) => FromPair arity (C1 c a) where

1407− parsePair (tag :* p@(_ :* opts :* _)) v

1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v

1041+ parsePair opts fargs (tag, value)

1042+ | tag == tag' = Just $ gParseJSON opts fargs value

14091043 | otherwise = Nothing

1410− where

1411− tag' = pack $ constructorTagModifier opts cname

1412− cname = conName (undefined :: M1 _i c _a _p)

1044+ where

1045+ tag' = pack $ constructorTagModifier opts $

1046+ conName (undefined :: t c a p)

14131047

14141048--------------------------------------------------------------------------------

14151049

14161050class FromUntaggedValue arity f where

1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a

1418− -> Value

1419− -> Parser (f a)

1051+ parseUntaggedValue :: Options -> FromArgs arity a

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

14201053

14211054instance

14221055 ( FromUntaggedValue arity a

14231056 , FromUntaggedValue arity b

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

14251058 where

1426− parseUntaggedValue p value =

1427− L1 <$> parseUntaggedValue p value <|>

1428− R1 <$> parseUntaggedValue p value

1059+ parseUntaggedValue opts fargs value =

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

1061+ R1 <$> parseUntaggedValue opts fargs value

14291062

14301063instance OVERLAPPABLE_

1431− ( ConsFromJSON arity a

1432− , Constructor c

1064+ ( GFromJSON arity a

1065+ , ConsFromJSON arity a

14331066 ) => FromUntaggedValue arity (C1 c a)

14341067 where

1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)

1436− where

1437− cname = conName (undefined :: M1 _i c _f _p)

1068+ parseUntaggedValue = gParseJSON

14381069

14391070instance OVERLAPPING_

14401071 ( Constructor c )

14411072 => FromUntaggedValue arity (C1 c U1)

14421073 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

1074+ parseUntaggedValue opts _ (String s)

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

1076+ pure $ M1 U1

1077+ | otherwise =

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

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

1080+

1081+

1082+--------------------------------------------------------------------------------

1083+

1084+notFound :: Text -> Parser a

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

1086+{-# INLINE notFound #-}

14541087

14551088-------------------------------------------------------------------------------

14561089-- Instances

@@ -1508,20 +1141,17 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where

15081141 parseJSON = parseJSON2

15091142 {-# INLINE parseJSON #-}

15101143

1511−instance FromJSON Void where

1512− parseJSON _ = fail "Cannot parse Void"

1513− {-# INLINE parseJSON #-}

1144+

15141145

15151146instance FromJSON Bool where

1516− parseJSON (Bool b) = pure b

1517− parseJSON v = typeMismatch "Bool" v

1147+ parseJSON = withBool "Bool" pure

15181148 {-# INLINE parseJSON #-}

15191149

15201150instance FromJSONKey Bool where

15211151 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of

15221152 "true" -> pure True

15231153 "false" -> pure False

1524− _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"

1154+ _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t

15251155

15261156instance FromJSON Ordering where

15271157 parseJSON = withText "Ordering" $ \s ->

@@ -1529,30 +1159,25 @@ instance FromJSON Ordering where

15291159 "LT" -> return LT

15301160 "EQ" -> return EQ

15311161 "GT" -> return GT

1532− _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++

1533− " (expected \"LT\", \"EQ\", or \"GT\")"

1162+ _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""

15341163

15351164instance FromJSON () where

15361165 parseJSON = withArray "()" $ \v ->

15371166 if V.null v

15381167 then pure ()

1539− else prependContext "()" $ fail "expected an empty array"

1168+ else fail "Expected an empty array"

15401169 {-# INLINE parseJSON #-}

15411170

15421171instance FromJSON Char where

1543− parseJSON = withText "Char" parseChar

1172+ parseJSON = withText "Char" $ \t ->

1173+ if T.compareLength t 1 == EQ

1174+ then pure $ T.head t

1175+ else fail "Expected a string of length 1"

15441176 {-# INLINE parseJSON #-}

15451177

1546− parseJSONList (String s) = pure (T.unpack s)

1547− parseJSONList v = typeMismatch "String" v

1178+ parseJSONList = withText "String" $ pure . T.unpack

15481179 {-# INLINE parseJSONList #-}

15491180

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−

15561181instance FromJSON Double where

15571182 parseJSON = parseRealFloat "Double"

15581183 {-# INLINE parseJSON #-}

@@ -1564,6 +1189,12 @@ instance FromJSONKey Double where

15641189 "-Infinity" -> pure (negate 1/0)

15651190 _ -> Scientific.toRealFloat <$> parseScientificText t

15661191

1192+instance FromJSON Number where

1193+ parseJSON (Number s) = pure $ scientificToNumber s

1194+ parseJSON Null = pure (D (0/0))

1195+ parseJSON v = typeMismatch "Number" v

1196+ {-# INLINE parseJSON #-}

1197+

15671198instance FromJSON Float where

15681199 parseJSON = parseRealFloat "Float"

15691200 {-# INLINE parseJSON #-}

@@ -1576,30 +1207,17 @@ instance FromJSONKey Float where

15761207 _ -> Scientific.toRealFloat <$> parseScientificText t

15771208

15781209instance (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.

1210+ parseJSON = withObject "Rational" $ \obj ->

1211+ (%) <$> obj .: "numerator"

1212+ <*> obj .: "denominator"

1213+ {-# INLINE parseJSON #-}

1214+

1215+-- | /WARNING:/ Only parse fixed-precision numbers from trusted input

1216+-- since an attacker could easily fill up the memory of the target

1217+-- system by specifying a scientific number with a big exponent like

1218+-- @1e1000000000@.

16011219instance HasResolution a => FromJSON (Fixed a) where

1602− parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)

1220+ parseJSON = withScientific "Fixed" $ pure . realToFrac

16031221 {-# INLINE parseJSON #-}

16041222

16051223instance FromJSON Int where

@@ -1609,10 +1227,10 @@ instance FromJSON Int where

16091227instance FromJSONKey Int where

16101228 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"

16111229

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.

1230+-- | /WARNING:/ Only parse Integers from trusted input since an

1231+-- attacker could easily fill up the memory of the target system by

1232+-- specifying a scientific number with a big exponent like

1233+-- @1e1000000000@.

16161234instance FromJSON Integer where

16171235 parseJSON = parseIntegral "Integer"

16181236 {-# INLINE parseJSON #-}

@@ -1621,21 +1239,16 @@ instance FromJSONKey Integer where

16211239 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"

16221240

16231241instance FromJSON Natural where

1624− parseJSON value = do

1625− integer <- parseIntegral "Natural" value

1626− parseNatural integer

1242+ parseJSON = withScientific "Natural" $ \s ->

1243+ if Scientific.coefficient s < 0

1244+ then fail $ "Expected a Natural number but got the negative number: " <> show s

1245+ else pure $ truncate s

16271246

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

1248+ fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->

1249+ if Scientific.coefficient s < 0

1250+ then fail $ "Expected a Natural number but got the negative number: " <> show s

1251+ else pure $ truncate s

16391252

16401253instance FromJSON Int8 where

16411254 parseJSON = parseBoundedIntegral "Int8"

@@ -1700,9 +1313,6 @@ instance FromJSON Word64 where

17001313instance FromJSONKey Word64 where

17011314 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"

17021315

1703−instance FromJSON CTime where

1704− parseJSON = fmap CTime . parseJSON

1705− {-# INLINE parseJSON #-}

17061316

17071317instance FromJSON Text where

17081318 parseJSON = withText "Text" pure

@@ -1732,17 +1342,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack

17321342 where

17331343 go [(v,[])] = return v

17341344 go (_ : xs) = go xs

1735− go _ = fail "parsing Version failed"

1345+ go _ = fail "could not parse Version"

17361346

17371347-------------------------------------------------------------------------------

17381348-- semigroups NonEmpty

17391349-------------------------------------------------------------------------------

17401350

17411351instance FromJSON1 NonEmpty where

1742− liftParseJSON p _ = withArray "NonEmpty" $

1352+ liftParseJSON p _ = withArray "NonEmpty a" $

17431353 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

17441354 where

1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"

1355+ ne [] = fail "Expected a NonEmpty but got an empty list"

17461356 ne (x:xs) = pure (x :| xs)

17471357 {-# INLINE liftParseJSON #-}

17481358

@@ -1763,7 +1373,7 @@ instance FromJSON Scientific where

17631373-------------------------------------------------------------------------------

17641374

17651375instance FromJSON1 DList.DList where

1766− liftParseJSON p _ = withArray "DList" $

1376+ liftParseJSON p _ = withArray "DList a" $

17671377 fmap DList.fromList .

17681378 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

17691379 {-# INLINE liftParseJSON #-}

@@ -1840,7 +1450,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where

18401450 inr = "InR"

18411451

18421452 liftParseJSON _ _ _ = fail $

1843− "parsing Sum failed, expected an object with a single property " ++

1453+ "expected an object with a single property " ++

18441454 "where the property key should be either " ++

18451455 "\"InL\" or \"InR\""

18461456 {-# INLINE liftParseJSON #-}

@@ -1854,7 +1464,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where

18541464-------------------------------------------------------------------------------

18551465

18561466instance FromJSON1 Seq.Seq where

1857− liftParseJSON p _ = withArray "Seq" $

1467+ liftParseJSON p _ = withArray "Seq a" $

18581468 fmap Seq.fromList .

18591469 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

18601470 {-# INLINE liftParseJSON #-}

@@ -1888,15 +1498,15 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where

18881498

18891499instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where

18901500 liftParseJSON p _ = case fromJSONKey of

1891− FromJSONKeyCoerce _ -> withObject "Map" $

1501+ FromJSONKeyCoerce _-> withObject "Map k v" $

18921502 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

1893− FromJSONKeyText f -> withObject "Map" $

1503+ FromJSONKeyText f -> withObject "Map k v" $

18941504 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

1895− FromJSONKeyTextParser f -> withObject "Map" $

1505+ FromJSONKeyTextParser f -> withObject "Map k v" $

18961506 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

1507+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

1508+ M.fromList <$> (Tr.sequence .

1509+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

19001510 {-# INLINE liftParseJSON #-}

19011511

19021512instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where

@@ -1922,18 +1532,18 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where

19221532

19231533instance FromJSON UUID.UUID where

19241534 parseJSON = withText "UUID" $

1925− maybe (fail "invalid UUID") pure . UUID.fromText

1535+ maybe (fail "Invalid UUID") pure . UUID.fromText

19261536

19271537instance FromJSONKey UUID.UUID where

19281538 fromJSONKey = FromJSONKeyTextParser $

1929− maybe (fail "invalid UUID") pure . UUID.fromText

1539+ maybe (fail "Invalid UUID") pure . UUID.fromText

19301540

19311541-------------------------------------------------------------------------------

19321542-- vector

19331543-------------------------------------------------------------------------------

19341544

19351545instance FromJSON1 Vector where

1936− liftParseJSON p _ = withArray "Vector" $

1546+ liftParseJSON p _ = withArray "Vector a" $

19371547 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed

19381548 {-# INLINE liftParseJSON #-}

19391549

@@ -1947,14 +1557,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe

19471557{-# INLINE vectorParseJSON #-}

19481558

19491559instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where

1950− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"

1560+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"

19511561

19521562instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where

1953− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"

1563+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"

19541564 {-# INLINE parseJSON #-}

19551565

19561566instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where

1957− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"

1567+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

19581568 {-# INLINE parseJSON #-}

19591569

19601570-------------------------------------------------------------------------------

@@ -1968,15 +1578,15 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where

19681578

19691579instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where

19701580 liftParseJSON p _ = case fromJSONKey of

1971− FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $

1581+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $

19721582 uc . H.traverseWithKey (\k v -> p v <?> Key k)

1973− FromJSONKeyText f -> withObject "HashMap" $

1583+ FromJSONKeyText f -> withObject "HashMap k v" $

19741584 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)

1975− FromJSONKeyTextParser f -> withObject "HashMap" $

1585+ FromJSONKeyTextParser f -> withObject "HashMap k v" $

19761586 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

1587+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

1588+ H.fromList <$> (Tr.sequence .

1589+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

19801590 where

19811591 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)

19821592 uc = unsafeCoerce

@@ -1997,33 +1607,11 @@ instance FromJSON DotNetTime where

19971607 parseJSON = withText "DotNetTime" $ \t ->

19981608 let (s,m) = T.splitAt (T.length t - 5) t

19991609 t' = T.concat [s,".",m]

2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

1610+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

20011611 Just d -> pure (DotNetTime d)

20021612 _ -> fail "could not parse .NET time"

20031613 {-# INLINE parseJSON #-}

20041614

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−

20271615-------------------------------------------------------------------------------

20281616-- time

20291617-------------------------------------------------------------------------------

@@ -2049,17 +1637,6 @@ instance FromJSONKey LocalTime where

20491637 fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)

20501638

20511639

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.

20631640instance FromJSON ZonedTime where

20641641 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)

20651642

@@ -2074,57 +1651,14 @@ instance FromJSONKey UTCTime where

20741651 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)

20751652

20761653

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.

1654+-- | /WARNING:/ Only parse lengths of time from trusted input

1655+-- since an attacker could easily fill up the memory of the target

1656+-- system by specifying a scientific number with a big exponent like

1657+-- @1e1000000000@.

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

1659+ parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac

20921660 {-# INLINE parseJSON #-}

20931661

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−

21281662-------------------------------------------------------------------------------

21291663-- base Monoid/Semigroup

21301664-------------------------------------------------------------------------------

@@ -2245,15 +1779,14 @@ instance FromJSON a => FromJSON (Semigroup.Option a) where

22451779

22461780instance FromJSON1 Proxy where

22471781 {-# INLINE liftParseJSON #-}

2248− liftParseJSON _ _ = fromNull "Proxy" Proxy

1782+ liftParseJSON _ _ Null = pure Proxy

1783+ liftParseJSON _ _ v = typeMismatch "Proxy" v

22491784

22501785instance FromJSON (Proxy a) where

22511786 {-# INLINE parseJSON #-}

2252− parseJSON = fromNull "Proxy" Proxy

1787+ parseJSON Null = pure Proxy

1788+ parseJSON v = typeMismatch "Proxy" v

22531789

2254−fromNull :: String -> a -> Value -> Parser a

2255−fromNull _ a Null = pure a

2256−fromNull c _ v = prependContext c (typeMismatch "Null" v)

22571790

22581791instance FromJSON2 Tagged where

22591792 liftParseJSON2 _ _ p _ = fmap Tagged . p

@@ -2280,7 +1813,10 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)

22801813instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)

22811814

22821815instance FromJSONKey Char where

2283− fromJSONKey = FromJSONKeyTextParser parseChar

1816+ fromJSONKey = FromJSONKeyTextParser $ \t ->

1817+ if T.length t == 1

1818+ then return (T.index t 0)

1819+ else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)

22841820 fromJSONKeyList = FromJSONKeyText T.unpack

22851821

22861822instance (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 =

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

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

11name: aeson

2−version: 1.4.6.0

2+version: 1.1.0.0

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,26 +150,14 @@ 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

@@ -195,49 +167,44 @@ test-suite tests

195167 Functions

196168 Instances

197169 Options

198− PropUtils

199170 Properties

200− PropertyGeneric

201− PropertyKeys

202− PropertyRoundTrip

203− PropertyRTFunctors

204− PropertyTH

205171 SerializationFormatSpec

206172 Types

207173 UnitTests

208174 UnitTests.NullaryConstructors

209175

176+ ghc-options: -Wall -threaded -rtsopts

177+

210178 build-depends:

211− QuickCheck >= 2.10.0.1 && < 2.14,

179+ HUnit,

180+ QuickCheck >= 2.8 && <2.9.3,

212181 aeson,

213182 integer-logarithms >= 1 && <1.1,

214183 attoparsec,

215184 base,

216185 base-compat,

217− base-orphans >= 0.5.3 && <0.9,

186+ base-orphans >= 0.5.3 && <0.6,

218187 base16-bytestring,

219188 containers,

220189 directory,

221190 dlist,

222− Diff >= 0.4 && < 0.5,

223191 filepath,

224− generic-deriving >= 1.10 && < 1.14,

192+ generic-deriving >= 1.10 && < 1.12,

225193 ghc-prim >= 0.2,

226194 hashable >= 1.2.4.0,

227195 scientific,

228196 tagged,

229197 template-haskell,

230− tasty,

231− tasty-golden,

232− tasty-hunit,

233− tasty-quickcheck,

198+ test-framework,

199+ test-framework-hunit,

200+ test-framework-quickcheck2,

234201 text,

235202 time,

236− time-compat,

203+ time-locale-compat,

237204 unordered-containers,

238205 uuid-types,

239206 vector,

240− quickcheck-instances >= 0.3.21 && <0.4

207+ quickcheck-instances >=0.3.12

241208

242209 if flag(bytestring-builder)

243210 build-depends: bytestring >= 0.9 && < 0.10.4,

@@ -247,20 +214,16 @@ test-suite tests

247214

248215 if !impl(ghc >= 8.0)

249216 build-depends:

250− semigroups >= 0.18.2 && < 0.20,

217+ semigroups >= 0.18.2 && < 0.19,

251218 transformers >= 0.2.2.0,

252219 transformers-compat >= 0.3

253220

254221 if !impl(ghc >= 7.10)

255− build-depends: nats >=1 && <1.2,

256− void >=0.7.2 && <0.8

222+ build-depends: nats >=1 && <1.2

257223

258224 if impl(ghc >= 7.8)

259225 build-depends: hashable-time >= 0.2 && <0.3

260226

261− if flag(fast)

262− ghc-options: -fno-enable-rewrite-rules

263−

264227source-repository head

265228 type: git

266229 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+1−186

@@ -1,191 +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

3+# 1.1.0.0

1894

1905* Added instances for `UUID`.

1916

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+7−10

@@ -1,12 +1,9 @@

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+- integer-logarithms-1

7+flags:

8+ semigroups:

9+ bytestring-builder: false

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

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

1+resolver: lts-6.27

2+packages:

3+- '.'

4+extra-deps:

5+- semigroups-0.18.2

6+- integer-logarithms-1

7+flags:

8+ aeson:

9+ fast: true

10+ semigroups:

11+ bytestring-builder: false

stack-ffi-unescape.yaml → stack-lts7.yamlrenamed+3−4

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

1−resolver: nightly-2019-09-21

1+resolver: lts-7.14

22packages:

33- '.'

4+extra-deps:

5+- integer-logarithms-1

46flags:

57 aeson:

68 fast: true

7− cffi: true

8−extra-deps:

9−- Diff-0.4.0

stack-nightly.yaml+3−6

@@ -1,11 +1,8 @@

1−resolver: nightly-2019-10-14

1+resolver: nightly-2016-12-22

22packages:

33- '.'

4−- attoparsec-iso8601

4+extra-deps:

5+- integer-logarithms-1

56flags:

67 aeson:

78 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.hs+41−208

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

1−{-# LANGUAGE NoImplicitPrelude #-}

21{-# LANGUAGE OverloadedStrings #-}

32{-# LANGUAGE ScopedTypeVariables #-}

@@ -7,218 +6,52 @@ module ErrorMessages

76 tests

87 ) where

9+import Prelude ()

1010import Prelude.Compat

1111

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)

12+import Data.Aeson (FromJSON(..), eitherDecode)

1713import Data.Proxy (Proxy(..))

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

19−import Data.Sequence (Seq)

2014import Instances ()

21−import Numeric.Natural (Natural)

22−import Test.Tasty (TestTree, TestName)

23−import Test.Tasty.Golden.Advanced (goldenTest)

15+import Test.Framework (Test)

16+import Test.Framework.Providers.HUnit (testCase)

17+import Test.HUnit (Assertion, assertFailure, assertEqual)

2418import qualified Data.ByteString.Lazy.Char8 as L

2519import qualified Data.HashMap.Strict as HM

2620

27−import Encoders

28−import Types

29−

30−tests :: [TestTree]

21+tests :: [Test]

3122tests =

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

23+ [

24+ testCase "Int" int

25+ , testCase "String" string

26+ , testCase "HashMap" hashMap

27+ ]

28+

29+int :: Assertion

30+int = do

31+ let t = test (Proxy :: Proxy Int)

32+ t "\"\"" $ expected "Int" "String"

33+ t "[]" $ expected "Int" "Array"

34+ t "{}" $ expected "Int" "Object"

35+ t "null" $ expected "Int" "Null"

36+

37+string :: Assertion

38+string = do

39+ let t = test (Proxy :: Proxy String)

40+ t "1" $ expected "String" "Number"

41+ t "[]" $ expected "String" "Array"

42+ t "{}" $ expected "String" "Object"

43+ t "null" $ expected "String" "Null"

44+

45+hashMap :: Assertion

46+hashMap = do

47+ let t = test (Proxy :: Proxy (HM.HashMap String Int))

48+ t "\"\"" $ expected "HashMap k v" "String"

49+ t "[]" $ expected "HashMap k v" "Array"

50+

51+expected :: String -> String -> String

52+expected ex enc = "Error in $: expected " ++ ex ++ ", encountered " ++ enc

53+

54+test :: forall a proxy . (FromJSON a, Show a) => proxy a -> L.ByteString -> String -> Assertion

55+test _ v msg = case eitherDecode v of

56+ Left e -> assertEqual "Invalid error message" msg e

57+ Right (x :: a) -> assertFailure $ "Expected parsing to fail but it suceeded with: " ++ show x

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+70−7

@@ -1,19 +1,25 @@

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.Functor.Identity (Identity (..))

20+import Data.Hashable (Hashable (..))

21+import Data.Proxy (Proxy(..))

22+import Data.Tagged (Tagged(..))

1723import Data.Time (ZonedTime(..), TimeZone(..))

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

1925import Functions

@@ -21,15 +27,30 @@ import Test.QuickCheck (Arbitrary(..), elements, oneof)

2127import Types

2228import qualified Data.DList as DList

2329import qualified Data.HashMap.Strict as HM

30+import qualified Data.UUID.Types as UUID

31+

32+#if !MIN_VERSION_QuickCheck(2,9,0)

33+import Control.Applicative (Const(..))

34+import Data.List.NonEmpty (NonEmpty(..))

35+import Data.Functor.Identity (Identity (..))

36+import Data.Version

37+import Test.QuickCheck (getNonNegative, listOf1, resize)

38+#endif

2439

2540import Data.Orphans ()

2641import Test.QuickCheck.Instances ()

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

2743import Data.Hashable.Time ()

44+#endif

45+

46+#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)

47+import Numeric.Natural

48+#endif

2849

2950-- "System" types.

3051

3152instance Arbitrary DotNetTime where

32− arbitrary = DotNetTime `fmap` arbitrary

53+ arbitrary = DotNetTime `liftM` arbitrary

3354 shrink = map DotNetTime . shrink . fromDotNetTime

3455

3556-- | Compare timezone part only on 'timeZoneMinutes'

@@ -153,15 +174,57 @@ instance Arbitrary EitherTextInt where

153174instance Arbitrary (GADT String) where

154175 arbitrary = GADT <$> arbitrary

155176

156−instance Arbitrary OptionField where

157− arbitrary = OptionField <$> arbitrary

158−

159−

160177instance ApproxEq Char where

161178 (=~) = (==)

162179

163180instance (ApproxEq a) => ApproxEq [a] where

164181 a =~ b = length a == length b && all (uncurry (=~)) (zip a b)

165182

183+-- Version tags are deprecated, so we avoid using them in the Arbitrary

184+-- instance. However, the recommended constructor 'makeVersion' is not

185+-- exported by "Data.Version" until base-4.8.0.0. For previous versions,

186+-- a definition is given below.

187+

188+

189+#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)

190+instance Arbitrary Natural where

191+ arbitrary = fromInteger . abs <$> arbitrary

192+#endif

193+

194+instance Arbitrary (Proxy a) where

195+ arbitrary = pure Proxy

196+

197+instance Arbitrary b => Arbitrary (Tagged a b) where

198+ arbitrary = Tagged <$> arbitrary

199+

166200instance Arbitrary a => Arbitrary (DList.DList a) where

167201 arbitrary = DList.fromList <$> arbitrary

202+

203+instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where

204+ arbitrary = Compose <$> arbitrary

205+

206+#if !MIN_VERSION_QuickCheck(2,9,0)

207+instance Arbitrary a => Arbitrary (Const a b) where

208+ arbitrary = Const <$> arbitrary

209+

210+instance Arbitrary a => Arbitrary (NonEmpty a) where

211+ arbitrary = (:|) <$> arbitrary <*> arbitrary

212+

213+instance Arbitrary Version where

214+ arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)

215+

216+#if !MIN_VERSION_base(4,8,0)

217+makeVersion :: [Int] -> Version

218+makeVersion b = Version b []

219+#endif

220+

221+instance Arbitrary a => Arbitrary (Identity a) where

222+ arbitrary = Identity <$> arbitrary

223+#endif

224+

225+instance Arbitrary UUID.UUID where

226+ arbitrary = UUID.fromWords

227+ <$> arbitrary

228+ <*> arbitrary

229+ <*> arbitrary

230+ <*> 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 :: LogScaled (Compose I I Int))

231+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))

232+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))

233+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))

234+

235+ , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))

236+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))

237+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))

238+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))

239+

240+ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))

241+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))

242+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))

243+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))

244+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))

245+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))

246+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))

247+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))

248+

249+ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))

250+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))

251+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))

252+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))

253+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))

254+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))

255+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))

256+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (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 :: LogScaled [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.hs+134−183

@@ -1,9 +1,10 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

54{-# LANGUAGE OverloadedStrings #-}

5+#if __GLASGOW_HASKELL__ >= 708

66{-# LANGUAGE DataKinds #-}

7+#endif

89------------------------------------------------------------------------------

910-- These tests assert that the JSON serialization doesn't change by accident.

@@ -14,13 +15,13 @@ module SerializationFormatSpec

1415 tests

1516 ) where

1617

18+import Prelude ()

1719import Prelude.Compat

1820

1921import Control.Applicative (Const(..))

2022import Data.Aeson (FromJSON(..), decode, encode, genericParseJSON, genericToEncoding, genericToJSON)

2123import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), defaultOptions)

2224import Data.Fixed (Pico)

23−import Data.Foldable (for_, toList)

2425import Data.Functor.Compose (Compose(..))

2526import Data.Functor.Identity (Identity(..))

2627import Data.Functor.Product (Product(..))

@@ -30,14 +31,12 @@ import Data.Proxy (Proxy(..))

3031import Data.Scientific (Scientific)

3132import Data.Tagged (Tagged(..))

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

3634import Data.Word (Word8)

3735import GHC.Generics (Generic)

3836import Instances ()

39−import Test.Tasty (TestTree, testGroup)

40−import Test.Tasty.HUnit (assertFailure, assertEqual, testCase)

37+import Test.Framework (Test, testGroup)

38+import Test.Framework.Providers.HUnit (testCase)

39+import Test.HUnit (assertFailure, assertEqual)

4140import Types (Approx(..), Compose3, Compose3', I)

4241import qualified Data.ByteString.Lazy.Char8 as L

4342import qualified Data.DList as DList

@@ -54,7 +53,7 @@ import qualified Data.Tree as Tree

5453import qualified Data.UUID.Types as UUID

5554import qualified Data.Vector as Vector

5655

57−tests :: [TestTree]

56+tests :: [Test]

5857tests =

5958 [

6059 testGroup "To JSON representation" $ fmap assertJsonEncodingExample jsonEncodingExamples

@@ -66,165 +65,141 @@ tests =

6665jsonExamples :: [Example]

6766jsonExamples =

6867 [

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)

68+ Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

69+ , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

70+ , Example "Nothing" "null" (Nothing :: Maybe Int)

71+ , Example "Just" "1" (Just 1 :: Maybe Int)

72+ , Example "Proxy Int" "null" (Proxy :: Proxy Int)

73+ , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

74+#if __GLASGOW_HASKELL__ >= 708

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

76+ , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

77+#endif

78+ , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

79+ , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

80+ , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

81+ , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)

82+ , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

83+ , Example "()" "[]" ()

84+

85+ , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

86+ , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int)

87+ , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)

88+ , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)

89+ , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map [Char] Int)

90+ , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)

91+

92+ , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)

93+

94+ , Example "Ordering LT" "\"LT\"" LT

95+ , Example "Ordering EQ" "\"EQ\"" EQ

96+ , Example "Ordering GT" "\"GT\"" GT

97+

98+ , Example "Float" "3.14" (3.14 :: Float)

99+ , Example "Pico" "3.14" (3.14 :: Pico)

100+ , Example "Scientific" "3.14" (3.14 :: Scientific)

101+

102+ , Example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords

117103 0xc2cc10e1 0x57d64b6f 0x989938d9 0x72112d8c

118104

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)

105+ , Example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)

106+ , Example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])

107+ , Example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)

108+ , Example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)

109+ , Example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)

110+ , 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)

125111

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

113+ , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))

114+ , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)

115+ , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)

130116

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

118+ , Example "Identity Int" "1" (pure 1 :: Identity Int)

119+

120+ , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)

121+ , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)

122+ , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])

123+

124+ , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)

125+ , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)

126+ , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])

127+

128+ , Example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)

129+ , Example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)

130+ , Example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)

131+ , Example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)

132+ , Example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)

133+

134+ , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)

135+ , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)

136+ , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)

137+

138+ , Example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)

139+ , Example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)

140+ , Example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)

141+

142+ , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)

143+ , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)

144+ , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)

145+ , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)

146+

147+ , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)

148+ , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)

149+ , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)

150+ , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)

151+

152+ , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)

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

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

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

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

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

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

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

160+

161+ , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)

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

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

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

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

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

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

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

169+

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

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

186172

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

174+ , Example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)

175+ , Example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)

176+ , Example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)

177+ , Example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)

178+ , Example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)

179+ , Example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)

180+ , Example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)

181+ , Example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)

182+ , Example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)

183+ , Example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))

211184 ]

212185

213186jsonEncodingExamples :: [Example]

214187jsonEncodingExamples =

215188 [

189+ -- Maybe serialising is lossy

190+ -- https://github.com/bos/aeson/issues/376

191+ Example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))

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

193+ , Example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)

219194 ]

220195

221196jsonDecodingExamples :: [Example]

222197jsonDecodingExamples = [

223198 -- Maybe serialising is lossy

224199 -- https://github.com/bos/aeson/issues/376

225− MaybeExample "Nothing" "null" (Just Nothing :: Maybe (Maybe Int))

200+ MaybeExample "Nothing" "null" (Just $ Nothing :: Maybe (Maybe Int))

226201 , MaybeExample "Just" "1" (Just $ Just 1 :: Maybe (Maybe Int))

227− , MaybeExample "Just Nothing" "null" (Just Nothing :: Maybe (Maybe (Maybe Int)))

202+ , MaybeExample "Just Nothing" "null" (Just $ Nothing :: Maybe (Maybe (Maybe Int)))

228203 -- Integral values are truncated, and overflowed

229204 -- https://github.com/bos/aeson/issues/317

230205 , MaybeExample "Word8 3" "3" (Just 3 :: Maybe Word8)

@@ -237,27 +212,12 @@ jsonDecodingExamples = [

237212 ]

238213

239214data 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)

215+ Example

216+ :: (Eq a, Show a, ToJSON a, FromJSON a)

253217 => 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−

218+ MaybeExample

219+ :: (Eq a, Show a, FromJSON a)

220+ => String -> L.ByteString -> Maybe a -> Example

261221

262222data MyEither a b = MyLeft a | MyRight b

263223 deriving (Generic, Show, Eq)

@@ -269,26 +229,17 @@ instance (ToJSON a, ToJSON b) => ToJSON (MyEither a b) where

269229instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where

270230 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

271231

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)

232+assertJsonExample :: Example -> Test

233+assertJsonExample (Example name bs val) = testCase name $ do

234+ assertEqual "encode" bs (encode val)

235+ assertEqual "encode/via value" bs (encode $ toJSON val)

236+ assertEqual "decode" (Just val) (decode bs)

278237assertJsonExample (MaybeExample name bs mval) = testCase name $

279238 assertEqual "decode" mval (decode bs)

280239

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)

240+assertJsonEncodingExample :: Example -> Test

241+assertJsonEncodingExample (Example name bs val) = testCase name $ do

242+ assertEqual "encode" bs (encode val)

243+ assertEqual "encode/via value" bs (encode $ toJSON val)

285244assertJsonEncodingExample (MaybeExample name _ _) = testCase name $

286245 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+6−11

@@ -4,21 +4,19 @@

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GADTs #-}

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE NoImplicitPrelude #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

97{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

109

11−module Types (module Types) where

10+module Types where

1211

12+import Prelude ()

1313import Prelude.Compat

1414

1515import Math.NumberTheory.Logarithms (intLog2)

16−import Control.Applicative ((<$>))

1716import Data.Data

1817import Data.Functor.Compose (Compose (..))

1918import Data.Functor.Identity (Identity (..))

2019import Data.Hashable (Hashable (..))

21−import Data.Semigroup (Option)

2220import Data.Text

2321import Data.Time (Day (..), fromGregorian)

2422import GHC.Generics

@@ -106,10 +104,6 @@ deriving instance Data (GADT String)

106104deriving instance Eq (GADT a)

107105deriving instance Show (GADT a)

108106

109−newtype MaybeField = MaybeField { maybeField :: Maybe Int }

110−newtype OptionField = OptionField { optionField :: Option Int }

111− deriving (Eq, Show)

112−

113107deriving instance Generic Foo

114108deriving instance Generic UFoo

115109deriving instance Generic OneConstructor

@@ -119,8 +113,9 @@ deriving instance Generic (Sum4 a b c d)

119113deriving instance Generic (Approx a)

120114deriving instance Generic Nullary

121115deriving instance Generic (SomeType a)

116+#if __GLASGOW_HASKELL__ >= 706

122117deriving instance Generic1 SomeType

123−deriving instance Generic OptionField

118+#endif

124119deriving instance Generic EitherTextInt

125120

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

@@ -151,7 +146,7 @@ instance Hashable a => Hashable (LogScaled a) where

151146 hashWithSalt salt (LogScaled a) = hashWithSalt salt a

152147

153148instance Arbitrary a => Arbitrary (LogScaled a) where

154− arbitrary = LogScaled <$> scale (\x -> intLog2 $ x + 1) arbitrary

149+ arbitrary = fmap LogScaled $ scale (\x -> intLog2 $ x + 1) arbitrary

155150 shrink = fmap LogScaled . shrink . getLogScaled

156151

157152instance ToJSON a => ToJSON (LogScaled a) where

tests/UnitTests.hs+58−325

@@ -1,80 +1,61 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE NoImplicitPrelude #-}

54{-# LANGUAGE OverloadedStrings #-}

65{-# LANGUAGE ScopedTypeVariables #-}

76{-# LANGUAGE TemplateHaskell #-}

8−{-# LANGUAGE QuasiQuotes #-}

108-- For Data.Aeson.Types.camelTo

119{-# OPTIONS_GHC -fno-warn-deprecations #-}

1210

13−#if MIN_VERSION_base(4,9,0)

14−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

15−#endif

16−

1711module UnitTests

1812 (

1913 ioTests

2014 , tests

21− , withEmbeddedJSONTest

2215 ) where

2316

17+import Prelude ()

2418import Prelude.Compat

2519

26−import Control.Monad (forM, forM_)

27−import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)

20+import Control.Monad (forM, forM_, unless)

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

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

29−import Data.Aeson.QQ.Simple (aesonQQ)

3023import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)

3124import 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)

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

4026import Data.Char (toUpper)

4127import Data.Either.Compat (isLeft, isRight)

4228import Data.Hashable (hash)

43−import Data.HashMap.Strict (HashMap)

44−import Data.List (sort, isSuffixOf)

29+import Data.List (sort)

4530import Data.Maybe (fromMaybe)

46−import Data.Scientific (Scientific, scientific)

31+import Data.Sequence (Seq)

4732import Data.Tagged (Tagged(..))

4833import Data.Text (Text)

4934import Data.Time (UTCTime)

50−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)

35+import Data.Time.Format (parseTime)

36+import Data.Time.Locale.Compat (defaultTimeLocale)

5137import GHC.Generics (Generic)

5238import Instances ()

53−import Numeric.Natural (Natural)

54−import System.Directory (getDirectoryContents)

39+import System.Directory (doesDirectoryExist, getDirectoryContents)

40+import System.Exit (exitWith, ExitCode(ExitFailure))

5541import System.FilePath ((</>), takeExtension, takeFileName)

56−import Test.Tasty (TestTree, testGroup)

57−import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))

42+import System.IO (hPutStrLn, stderr)

43+import Test.Framework (Test, testGroup)

44+import Test.Framework.Providers.HUnit (testCase)

45+import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)

5846import Text.Printf (printf)

5947import UnitTests.NullaryConstructors (nullaryConstructors)

60−import qualified Data.ByteString as S

6148import qualified Data.ByteString.Base16.Lazy as LBase16

6249import qualified Data.ByteString.Lazy.Char8 as L

6350import qualified Data.HashSet as HashSet

64−import qualified Data.HashMap.Lazy as HashMap

6551import qualified Data.Text.Lazy as LT

6652import qualified Data.Text.Lazy.Builder as TLB

6753import qualified Data.Text.Lazy.Encoding as LT

6854import qualified Data.Text.Lazy.Encoding as TLE

69−import qualified Data.Vector as Vector

7055import qualified ErrorMessages

7156import qualified SerializationFormatSpec

7257

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

58+tests :: Test

7859tests = testGroup "unit" [

7960 testGroup "SerializationFormatSpec" SerializationFormatSpec.tests

8061 , testGroup "ErrorMessages" ErrorMessages.tests

@@ -91,41 +72,23 @@ tests = testGroup "unit" [

9172 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")

9273 ]

9374 , testGroup "encoding" [

94− testCase "goodProducer" goodProducer

75+ testCase "goodProducer" $ goodProducer

9576 ]

9677 , testGroup "utctime" [

97− testCase "good" utcTimeGood

98− , testCase "bad" utcTimeBad

78+ testCase "good" $ utcTimeGood

79+ , testCase "bad" $ utcTimeBad

9980 ]

10081 , testGroup "formatError" [

101− testCase "example 1" formatErrorExample

82+ testCase "example 1" $ formatErrorExample

10283 ]

10384 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark

85+ , testGroup "JSONPath" $ fmap (testCase "-") jsonPath

10486 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws

105− , testGroup "Object construction" $ fmap (testCase "-") objectConstruction

10687 , testGroup "Issue #351" $ fmap (testCase "-") issue351

10788 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors

10889 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions

10990 , testCase "PR #455" pr455

11091 , 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− ]

12992 ]

13093

13194roundTripCamel :: String -> Assertion

@@ -218,20 +181,14 @@ utcTimeGood = do

218181 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11

219182 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12

220183

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−

229184 where

230185 parseWithRead :: String -> LT.Text -> UTCTime

231186 parseWithRead f s =

232− fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s

187+ case parseTime defaultTimeLocale f . LT.unpack $ s of

188+ Nothing -> error "parseTime input malformed"

189+ Just t -> t

233190 parseWithAeson :: LT.Text -> Maybe UTCTime

234− parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]

191+ parseWithAeson s = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""])

235192

236193-- Test that a few non-timezone qualified timestamp formats get

237194-- rejected if decoding to UTCTime.

@@ -245,10 +202,9 @@ utcTimeBad = do

245202 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given

246203 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits

247204 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

249205 where

250206 verifyFailParse (s :: LT.Text) =

251− let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in

207+ let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ (LT.concat ["\"", s, "\""]) in

252208 assertEqual "verify failure" Nothing dec

253209

254210-- Non identifier keys should be escaped & enclosed in brackets

@@ -258,18 +214,6 @@ formatErrorExample =

258214 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

259215 in assertEqual "formatError example" lhs rhs

260216

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−

273217------------------------------------------------------------------------------

274218-- Comparison (.:?) and (.:!)

275219------------------------------------------------------------------------------

@@ -288,11 +232,11 @@ dotColonMark = [

288232 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)

289233 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)

290234

291− , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2)

235+ , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2)

292236 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)

293237 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)

294238

295− , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3)

239+ , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3)

296240 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)

297241 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)

298242 ]

@@ -300,6 +244,27 @@ dotColonMark = [

300244 ex2 = "{\"value\": 42 }"

301245 ex3 = "{\"value\": null }"

302246

247+------------------------------------------------------------------------------

248+-- These tests check that JSONPath is tracked correctly

249+-----------------------------------------------------------------------------

250+

251+jsonPath :: [Assertion]

252+jsonPath = [

253+ -- issue #356

254+ assertEqual "Either"

255+ (Left "Error in $[1].Left[1]: expected Bool, encountered Number")

256+ (eitherDecode "[1,{\"Left\":[2,3]}]"

257+ :: Either String (Int, Either (Int, Bool) ()))

258+ -- issue #358

259+ , assertEqual "Seq a"

260+ (Left "Error in $[2]: expected Int, encountered Boolean")

261+ (eitherDecode "[0,1,true]" :: Either String (Seq Int))

262+ , assertEqual "Wibble"

263+ (Left "Error in $.wibbleInt: expected Int, encountered Boolean")

264+ (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"

265+ :: Either String Wibble)

266+ ]

267+

303268------------------------------------------------------------------------------

304269-- Check that the hashes of two equal Value are the same

305270------------------------------------------------------------------------------

@@ -312,18 +277,6 @@ hashableLaws = [

312277 a = object ["223" .= False, "807882556" .= True]

313278 b = object ["807882556" .= True, "223" .= False]

314279

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−

327280-------------------------------------------------------------------------------

328281-- ToJSONKey

329282-------------------------------------------------------------------------------

@@ -384,13 +337,13 @@ issue351 = [

384337-- Comparison between bytestring and text encoders

385338------------------------------------------------------------------------------

386339

387−ioTests :: IO [TestTree]

340+ioTests :: IO [Test]

388341ioTests = do

389342 enc <- encoderComparisonTests

390343 js <- jsonTestSuite

391344 return [enc, js]

392345

393−encoderComparisonTests :: IO TestTree

346+encoderComparisonTests :: IO Test

394347encoderComparisonTests = do

395348 encoderTests <- forM testFiles $ \file0 -> do

396349 let file = "benchmarks/json-data/" ++ file0

@@ -450,7 +403,7 @@ unescapeString = do

450403

451404-- JSONTestSuite

452405

453−jsonTestSuiteTest :: FilePath -> TestTree

406+jsonTestSuiteTest :: FilePath -> Test

454407jsonTestSuiteTest path = testCase fileName $ do

455408 payload <- L.readFile path

456409 let result = eitherDecode payload :: Either String Value

@@ -465,9 +418,15 @@ jsonTestSuiteTest path = testCase fileName $ do

465418-- Build a collection of tests based on the current contents of the

466419-- JSONTestSuite test directories.

467420

468−jsonTestSuite :: IO TestTree

421+jsonTestSuite :: IO Test

469422jsonTestSuite = do

470423 let suitePath = "tests/JSONTestSuite"

424+ exists <- doesDirectoryExist suitePath

425+ unless exists $ do

426+ hPutStrLn stderr $ "git clone https://github.com/nst/JSONTestSuite " ++

427+ suitePath

428+ exitWith (ExitFailure 1)

429+ -- ignore test_transform for now

471430 let suites = ["test_parsing", "test_transform"]

472431 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do

473432 let dir = suitePath </> suite

@@ -528,233 +487,7 @@ pr455 = assertEqual "FooCons FooNil"

528487 foo :: Foo Int

529488 foo = FooCons FooNil

530489

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−

750490deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord

751491

752492deriveToJSON defaultOptions ''Foo

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