git.iko.soy/typeable/aeson
on ecc0663 help sign in
817ad94
swap
0 ahead, 191 behind
100 files changed+1689−3984
since splitsnapshots
unifiedsplit
.gitignore−4 .hlint.yaml−11 .travis.yml+19−40 CONTRIBUTING.md−38 Data/Aeson.hs+4−60 Data/Aeson/Compat.hs+16 Data/Aeson/Encode.hs+1−2 Data/Aeson/Encoding.hs+1−2 Data/Aeson/Encoding/Builder.hs+79−6 Data/Aeson/Encoding/Internal.hs+1−2 Data/Aeson/Internal.hs+1−1 Data/Aeson/Internal/Functions.hs+1−1 Data/Aeson/Parser.hs+2−12 Data/Aeson/Parser/Internal.hs+51−219 Data/Aeson/Parser/Time.hs+1−2 Data/Aeson/QQ/Simple.hs−25 Data/Aeson/TH.hs+62−53 Data/Aeson/Text.hs+4−5 Data/Aeson/Types.hs+2−22 Data/Aeson/Types/Class.hs+3−7 Data/Aeson/Types/FromJSON.hs+424−805 Data/Aeson/Types/Generic.hs+8−12 Data/Aeson/Types/Internal.hs+10−121 Data/Aeson/Types/ToJSON.hs+64−195 HLint.hs+10 Makefile+1−1 README.markdown+2−1 aeson.cabal+54−65 attoparsec-iso8601/Data/Attoparsec/Time.hs+5−4 attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs+18−21 attoparsec-iso8601/attoparsec-iso8601.cabal+3−3 attoparsec-iso8601/changelog.md−5 benchmarks/AesonEncode.hs+2−2 benchmarks/AesonFoldable.hs+1−1 benchmarks/AesonMap.hs+1−1 benchmarks/AesonParse.hs+1−1 benchmarks/AesonTuples.hs+1−2 benchmarks/Compare.hs+3−9 benchmarks/Compare/BufferBuilder.hs+3−2 benchmarks/Compare/JsonBench.hs+9−18 benchmarks/Compare/JsonBuilder.hs+3−2 benchmarks/CompareWithJSON.hs+2−3 benchmarks/Dates.hs+2−2 benchmarks/Escape.hs+1−2 benchmarks/Issue673.hs−165 benchmarks/JsonParse.hs+2−3 benchmarks/Micro.hs+1−2 benchmarks/ReadFile.hs+1−1 benchmarks/Typed.hs+1−2 benchmarks/Typed/Common.hs+1−2 benchmarks/Typed/Generic.hs+1−2 benchmarks/Typed/Manual.hs+1−2 benchmarks/Typed/TH.hs+1−2 benchmarks/aeson-benchmarks.cabal+26−52 cabal.project+1−4 changelog.md−134 examples/Generic.hs+1−1 examples/Simplest.hs+1−1 examples/TemplateHaskell.hs+1−1 examples/Twitter.hs+2−1 examples/Twitter/Generic.hs+1−2 examples/Twitter/Manual.hs+4−3 examples/Twitter/TH.hs+1−2 ffi/Data/Aeson/Parser/UnescapeFFI.hs+1−1 run-hlint.sh−7 stack-bench.yaml+3−2 stack-ffi-unescape.yaml+1−3 stack-lts12.yaml−15 stack-lts6.yaml+24 stack-lts7.yaml+17 stack-lts8.yaml+15 stack-lts9.yaml+12 stack-nightly.yaml+1−3 tests/DataFamilies/Encoders.hs+1−1 tests/DataFamilies/Instances.hs+1−2 tests/DataFamilies/Properties.hs+5−6 tests/DataFamilies/Types.hs+1−1 tests/Encoders.hs+7−49 tests/ErrorMessages.hs+54−207 tests/Functions.hs+1−2 tests/Instances.hs+5−3 tests/JSONTestSuite/parsers/test_haskell-aeson/testaeson.cabal+3−5 tests/Options.hs+1−13 tests/PropUtils.hs−208 tests/Properties.hs+532−14 tests/PropertyGeneric.hs−116 tests/PropertyKeys.hs−40 tests/PropertyRTFunctors.hs−51 tests/PropertyRoundTrip.hs−74 tests/PropertyTH.hs−130 tests/SerializationFormatSpec.hs+30−53 tests/Tests.hs+3−5 tests/Types.hs+5−4 tests/UnitTests.hs+38−256 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+2−4
.gitignore−4
@@ -5,7 +5,6 @@ dist-newstyle
55cabal.sandbox.config
66.stack-work/
77.stack-work-bench/
8−*.yaml.lock
98
109*.o
1110*.hi
@@ -14,9 +13,6 @@ cabal.sandbox.config
1413.\#*
1514\#*
1615
17−# Emacs backup files
18−*~
19−
2016benchmarks/AesonEncode
2117
2218tests/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+19−40
@@ -12,58 +12,37 @@ 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−
22+ - env: BUILD=hlint CABALVER=2.0 GHCVER=8.2.1
23+ compiler: ": #GHC 8.2.1"
24+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}
25+ - env: BUILD=stack CABALVER=2.0 GHCVER=8.2.1 STACK_YAML=stack-bench.yaml
26+ compiler: ": #GHC 8.2.1"
27+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}
28+ - env: BUILD=stack CABALVER=2.0 GHCVER=8.2.1 STACK_YAML=stack-ffi-unescape.yaml
29+ compiler: ": #GHC 8.2.1"
30+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}
5631 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2
5732 compiler: ": #GHC 8.0.2"
5833 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}
59−
60− - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3
61− compiler: ": #GHC 7.10.3"
62− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
63−
34+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.4.2
35+ compiler: ": #GHC 7.4.2"
36+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}
37+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.6.3
38+ compiler: ": #GHC 7.6.3"
39+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
6440 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4
6541 compiler: ": #GHC 7.8.4"
6642 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
43+ - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3
44+ compiler: ": #GHC 7.10.3"
45+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
6746
6847before_install:
6948 - unset CC
CONTRIBUTING.md−38
@@ -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+4−60
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21-- |
32-- Module: Data.Aeson
43-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -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
@@ -116,15 +103,12 @@ module Data.Aeson
116103 , SumEncoding(..)
117104 , camelTo2
118105 , defaultTaggedObject
119− -- ** Options for object keys
120− , JSONKeyOptions
121− , keyModifier
122− , defaultJSONKeyOptions
123106
124107 -- * Inspecting @'Value's@
125108 , withObject
126109 , withText
127110 , withArray
111+ , withNumber
128112 , withScientific
129113 , withBool
130114 , withEmbeddedJSON
@@ -140,16 +124,16 @@ module Data.Aeson
140124 -- * Parsing
141125 , json
142126 , json'
143− , parseIndexedJSON
144127 ) where
145128
129+import Prelude ()
146130import Prelude.Compat
147131
148−import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)
132+import Data.Aeson.Types.FromJSON (ifromJSON)
149133import Data.Aeson.Encoding (encodingToLazyByteString)
150134import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')
151135import Data.Aeson.Types
152−import Data.Aeson.Types.Internal (JSONPath, formatError, (<?>))
136+import Data.Aeson.Types.Internal (JSONPath, formatError)
153137import qualified Data.ByteString as B
154138import qualified Data.ByteString.Lazy as L
155139
@@ -159,10 +143,6 @@ import qualified Data.ByteString.Lazy as L
159143encode :: (ToJSON a) => a -> L.ByteString
160144encode = encodingToLazyByteString . toEncoding
161145
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−
166146-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.
167147-- If this fails due to incomplete or invalid input, 'Nothing' is
168148-- returned.
@@ -189,18 +169,6 @@ decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a
189169decodeStrict = decodeStrictWith jsonEOF fromJSON
190170{-# INLINE decodeStrict #-}
191171
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−
204172-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.
205173-- If this fails due to incomplete or invalid input, 'Nothing' is
206174-- returned.
@@ -227,18 +195,6 @@ decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a
227195decodeStrict' = decodeStrictWith jsonEOF' fromJSON
228196{-# INLINE decodeStrict' #-}
229197
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−
242198eitherFormatError :: Either (JSONPath, String) a -> Either String a
243199eitherFormatError = either (Left . uncurry formatError) Right
244200{-# INLINE eitherFormatError #-}
@@ -254,12 +210,6 @@ eitherDecodeStrict =
254210 eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON
255211{-# INLINE eitherDecodeStrict #-}
256212
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−
263213-- | Like 'decode'' but returns an error message when decoding fails.
264214eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a
265215eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON
@@ -271,12 +221,6 @@ eitherDecodeStrict' =
271221 eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON
272222{-# INLINE eitherDecodeStrict' #-}
273223
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−
280224-- $use
281225--
282226-- This section contains basic information on the different ways to
Data/Aeson/Compat.hsnew file+16
@@ -0,0 +1,16 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Data.Aeson.Compat
4+ (
5+ fromStrict
6+ ) where
7+
8+import qualified Data.ByteString as S
9+import qualified Data.ByteString.Lazy as L
10+
11+fromStrict :: S.ByteString -> L.ByteString
12+#if MIN_VERSION_bytestring(0, 9, 2)
13+fromStrict = L.fromChunks . (:[])
14+#else
15+fromStrict = L.fromStrict
16+#endif
Data/Aeson/Encode.hs+1−2
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21-- |
32-- Module: Data.Aeson.Encode
43-- Copyright: (c) 2012-2016 Bryan O'Sullivan
@@ -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−2
@@ -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
@@ -51,5 +49,6 @@ module Data.Aeson.Encoding
5149 , value
5250 ) where
5351
52+import Prelude ()
5453
5554import Data.Aeson.Encoding.Internal
Data/Aeson/Encoding/Builder.hs+79−6
@@ -1,6 +1,6 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
3−{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE CPP #-}
3+
44-- |
55-- Module: Data.Aeson.Encoding.Builder
66-- Copyright: (c) 2011 MailRank, Inc.
@@ -36,6 +36,7 @@ module Data.Aeson.Encoding.Builder
3636 , ascii5
3737 ) where
3838
39+import Prelude ()
3940import Prelude.Compat
4041
4142import Data.Aeson.Internal.Time
@@ -44,9 +45,8 @@ import Data.ByteString.Builder as B
4445import Data.ByteString.Builder.Prim as BP
4546import Data.ByteString.Builder.Scientific (scientificBuilder)
4647import Data.Char (chr, ord)
47−import Data.Semigroup ((<>))
48+import Data.Monoid ((<>))
4849import Data.Scientific (Scientific, base10Exponent, coefficient)
49−import Data.Text.Encoding (encodeUtf8BuilderEscaped)
5050import Data.Time (UTCTime(..))
5151import Data.Time.Calendar (Day(..), toGregorian)
5252import Data.Time.LocalTime
@@ -55,6 +55,20 @@ import qualified Data.HashMap.Strict as HMS
5555import qualified Data.Text as T
5656import qualified Data.Vector as V
5757
58+#if MIN_VERSION_bytestring(0,10,4)
59+import Data.Text.Encoding (encodeUtf8BuilderEscaped)
60+#else
61+import Data.Bits ((.&.))
62+import Data.Text.Internal (Text(..))
63+import Data.Text.Internal.Unsafe.Shift (shiftR)
64+import Foreign.Ptr (minusPtr, plusPtr)
65+import Foreign.Storable (poke)
66+import qualified Data.ByteString.Builder.Internal as B
67+import qualified Data.ByteString.Builder.Prim.Internal as BP
68+import qualified Data.Text.Array as A
69+import qualified Data.Text.Internal.Encoding.Utf16 as U16
70+#endif
71+
5872-- | Encode a JSON value to a "Data.ByteString" 'B.Builder'.
5973--
6074-- Use this function if you are encoding over the wire, or need to
@@ -133,7 +147,7 @@ c2w c = fromIntegral (ord c)
133147-- | Encode a JSON number.
134148scientific :: Scientific -> Builder
135149scientific s
136− | e < 0 || e > 1024 = scientificBuilder s
150+ | e < 0 = scientificBuilder s
137151 | otherwise = B.integerDec (coefficient s * 10 ^ e)
138152 where
139153 e = base10Exponent s
@@ -201,7 +215,7 @@ timeOfDay64 (TOD h m s)
201215 !(T mh ml) = twoDigits m
202216 !(T sh sl) = twoDigits (fromIntegral real)
203217 (real,frac) = s `quotRem` pico
204− showFrac = ('.',) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)
218+ showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)
205219 trunc12 = (`quotRem` micro) >$<
206220 BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)
207221 digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)
@@ -254,3 +268,62 @@ twoDigits a = T (digit hi) (digit lo)
254268
255269digit :: Int -> Char
256270digit x = chr (x + 48)
271+
272+#if !(MIN_VERSION_bytestring(0,10,4))
273+-- | Encode text using UTF-8 encoding and escape the ASCII characters using
274+-- a 'BP.BoundedPrim'.
275+--
276+-- Use this function is to implement efficient encoders for text-based formats
277+-- like JSON or HTML.
278+{-# INLINE encodeUtf8BuilderEscaped #-}
279+-- TODO: Extend documentation with references to source code in @blaze-html@
280+-- or @aeson@ that uses this function.
281+encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder
282+encodeUtf8BuilderEscaped be =
283+ -- manual eta-expansion to ensure inlining works as expected
284+ \txt -> B.builder (mkBuildstep txt)
285+ where
286+ bound = max 4 $ BP.sizeBound be
287+
288+ mkBuildstep (Text arr off len) !k =
289+ outerLoop off
290+ where
291+ iend = off + len
292+
293+ outerLoop !i0 br@(B.BufferRange op0 ope)
294+ | i0 >= iend = k br
295+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
296+ -- TODO: Use a loop with an integrated bound's check if outRemaining
297+ -- is smaller than 8, as this will save on divisions.
298+ | otherwise = return $ B.bufferFull bound op0 (outerLoop i0)
299+ where
300+ outRemaining = (ope `minusPtr` op0) `div` bound
301+ inpRemaining = iend - i0
302+
303+ goPartial !iendTmp = go i0 op0
304+ where
305+ go !i !op
306+ | i < iendTmp = case A.unsafeIndex arr i of
307+ w | w <= 0x7F ->
308+ BP.runB be (fromIntegral w) op >>= go (i + 1)
309+ | w <= 0x7FF -> do
310+ poke8 0 $ (w `shiftR` 6) + 0xC0
311+ poke8 1 $ (w .&. 0x3f) + 0x80
312+ go (i + 1) (op `plusPtr` 2)
313+ | 0xD800 <= w && w <= 0xDBFF -> do
314+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))
315+ poke8 0 $ (c `shiftR` 18) + 0xF0
316+ poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80
317+ poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80
318+ poke8 3 $ (c .&. 0x3F) + 0x80
319+ go (i + 2) (op `plusPtr` 4)
320+ | otherwise -> do
321+ poke8 0 $ (w `shiftR` 12) + 0xE0
322+ poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80
323+ poke8 2 $ (w .&. 0x3F) + 0x80
324+ go (i + 1) (op `plusPtr` 3)
325+ | otherwise =
326+ outerLoop i (B.BufferRange op ope)
327+ where
328+ poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)
329+#endif
Data/Aeson/Encoding/Internal.hs+1−2
@@ -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
@@ -57,6 +55,7 @@ module Data.Aeson.Encoding.Internal
5755 , comma, colon, openBracket, closeBracket, openCurly, closeCurly
5856 ) where
5957
58+import Prelude ()
6059import Prelude.Compat
6160
6261import Data.Aeson.Types.Internal (Value)
Data/Aeson/Internal.hs+1−1
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21-- |
32-- Module: Data.Aeson.Internal
43-- Copyright: (c) 2015-2016 Bryan O'Sullivan
@@ -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
43-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -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/Parser.hs+2−12
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21-- |
32-- Module: Data.Aeson.Parser
43-- Copyright: (c) 2012-2016 Bryan O'Sullivan
@@ -35,20 +34,10 @@ module Data.Aeson.Parser
3534 , value
3635 , jstring
3736 , scientific
38− -- ** Handling objects with duplicate keys
39− , jsonWith
40− , jsonLast
41− , jsonAccum
42− , jsonNoDup
4337 -- * Strict parsers
4438 -- $strict
4539 , json'
4640 , value'
47− -- ** Handling objects with duplicate keys
48− , jsonWith'
49− , jsonLast'
50− , jsonAccum'
51− , jsonNoDup'
5241 -- * Decoding without FromJSON instances
5342 , decodeWith
5443 , decodeStrictWith
@@ -56,8 +45,9 @@ module Data.Aeson.Parser
5645 , eitherDecodeStrictWith
5746 ) where
5847
48+import Prelude ()
5949
60−import Data.Aeson.Parser.Internal
50+import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, scientific, value, value')
6151
6252-- $lazy
6353--
Data/Aeson/Parser/Internal.hs+51−219
@@ -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
7+
128-- |
139-- Module: Data.Aeson.Parser.Internal
1410-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -25,43 +21,30 @@ module Data.Aeson.Parser.Internal
2521 (
2622 -- * Lazy parsers
2723 json, jsonEOF
28− , jsonWith
29− , jsonLast
30− , jsonAccum
31− , jsonNoDup
3224 , value
3325 , jstring
3426 , jstring_
3527 , scientific
3628 -- * Strict parsers
3729 , json', jsonEOF'
38− , jsonWith'
39− , jsonLast'
40− , jsonAccum'
41− , jsonNoDup'
4230 , value'
4331 -- * Helpers
4432 , decodeWith
4533 , decodeStrictWith
4634 , eitherDecodeWith
4735 , eitherDecodeStrictWith
48− -- ** Handling objects with duplicate keys
49− , fromListAccum
50− , parseListNoDup
5136 ) where
5237
38+import Prelude ()
5339import Prelude.Compat
5440
5541import Control.Applicative ((<|>))
5642import Control.Monad (void, when)
57−import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))
43+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
5844import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
59−import Data.Function (fix)
60−import Data.Functor.Compat (($>))
6145import Data.Scientific (Scientific)
6246import Data.Text (Text)
63−import Data.Vector (Vector)
64−import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
47+import Data.Vector as Vector (Vector, empty, fromListN, reverse)
6548import qualified Data.Attoparsec.ByteString as A
6649import qualified Data.Attoparsec.Lazy as L
6750import qualified Data.ByteString as B
@@ -93,7 +76,7 @@ import qualified Data.Text.Encoding as TE
9376#define C_n 110
9477#define C_t 116
9578
96−-- | Parse any JSON value.
79+-- | Parse a top-level JSON value.
9780--
9881-- The conversion of a parsed value to a Haskell value is deferred
9982-- until the Haskell value is needed. This may improve performance if
@@ -103,15 +86,10 @@ import qualified Data.Text.Encoding as TE
10386-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
10487-- parsed only object or array types, in conformance with the
10588-- 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'.
11189json :: Parser Value
11290json = value
11391
114−-- | Parse any JSON value.
92+-- | Parse a top-level JSON value.
11593--
11694-- This is a strict version of 'json' which avoids building up thunks
11795-- during parsing; it performs all conversions immediately. Prefer
@@ -120,35 +98,23 @@ json = value
12098-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
12199-- parsed only object or array types, in conformance with the
122100-- 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''.
128101json' :: Parser Value
129102json' = value'
130103
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.
134−
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_ #-}
104+object_ :: Parser Value
105+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
138106
139−object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value
140−object_' mkObject val' = {-# SCC "object_'" #-} do
141− !vals <- objectValues mkObject jstring' val'
107+object_' :: Parser Value
108+object_' = {-# SCC "object_'" #-} do
109+ !vals <- objectValues jstring' value'
142110 return (Object vals)
143111 where
144112 jstring' = do
145113 !s <- jstring
146114 return s
147−{-# INLINE object_' #-}
148115
149−objectValues :: ([(Text, Value)] -> Either String Object)
150− -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
151−objectValues mkObject str val = do
116+objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
117+objectValues str val = do
152118 skipSpace
153119 w <- A.peekWord8'
154120 if w == CLOSE_CURLY
@@ -158,26 +124,22 @@ objectValues mkObject str val = do
158124 -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'
159125 -- and it's much faster because it's doing in place update to the 'HashMap'!
160126 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 '}'"
127+ k <- str <* skipSpace <* char ':'
128+ v <- val <* skipSpace
129+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY
164130 let acc' = (k, v) : acc
165131 if ch == COMMA
166132 then skipSpace >> loop acc'
167− else case mkObject acc' of
168− Left err -> fail err
169− Right obj -> pure obj
133+ else return (H.fromList acc')
170134{-# INLINE objectValues #-}
171135
172−array_ :: Parser Value -> Parser Value
173−array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
174−{-# INLINE array_ #-}
136+array_ :: Parser Value
137+array_ = {-# SCC "array_" #-} Array <$> arrayValues value
175138
176−array_' :: Parser Value -> Parser Value
177−array_' val = {-# SCC "array_'" #-} do
178− !vals <- arrayValues val
139+array_' :: Parser Value
140+array_' = {-# SCC "array_'" #-} do
141+ !vals <- arrayValues value'
179142 return (Array vals)
180−{-# INLINE array_' #-}
181143
182144arrayValues :: Parser Value -> Parser (Vector Value)
183145arrayValues val = do
@@ -188,133 +150,57 @@ arrayValues val = do
188150 else loop [] 1
189151 where
190152 loop acc !len = do
191− v <- (val A.<?> "json list value") <* skipSpace
192− ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"
153+ v <- val <* skipSpace
154+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE
193155 if ch == COMMA
194156 then skipSpace >> loop (v:acc) (len+1)
195157 else return (Vector.reverse (Vector.fromListN len (v:acc)))
196158{-# INLINE arrayValues #-}
197159
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.
160+-- | Parse any JSON value. You should usually 'json' in preference to
161+-- this function, as this function relaxes the object-or-array
162+-- requirement of RFC 4627.
207163--
208−-- ==== __Examples__
209−--
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
164+-- In particular, be careful in using this function if you think your
165+-- code might interoperate with Javascript. A na&#xef;ve Javascript
166+-- library that parses JSON data using @eval@ is vulnerable to attack
167+-- unless the encoded data represents an object or an array. JSON
168+-- implementations in other languages conform to that same restriction
169+-- to preserve interoperability and security.
170+value :: Parser Value
171+value = do
237172 skipSpace
238173 w <- A.peekWord8'
239174 case w of
240175 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
176+ OPEN_CURLY -> A.anyWord8 *> object_
177+ OPEN_SQUARE -> A.anyWord8 *> array_
178+ C_f -> string "false" *> pure (Bool False)
179+ C_t -> string "true" *> pure (Bool True)
180+ C_n -> string "null" *> pure Null
246181 _ | w >= 48 && w <= 57 || w == 45
247182 -> Number <$> scientific
248183 | 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))
254184
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)
259−
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''.
185+-- | Strict version of 'value'. See also 'json''.
282186value' :: 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
187+value' = do
288188 skipSpace
289189 w <- A.peekWord8'
290190 case w of
291191 DOUBLE_QUOTE -> do
292192 !s <- A.anyWord8 *> jstring_
293193 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
194+ OPEN_CURLY -> A.anyWord8 *> object_'
195+ OPEN_SQUARE -> A.anyWord8 *> array_'
196+ C_f -> string "false" *> pure (Bool False)
197+ C_t -> string "true" *> pure (Bool True)
198+ C_n -> string "null" *> pure Null
299199 _ | w >= 48 && w <= 57 || w == 45
300200 -> do
301201 !n <- scientific
302202 return (Number n)
303203 | 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
318204
319205-- | Parse a quoted JSON string.
320206jstring :: Parser Text
@@ -390,12 +276,7 @@ eitherDecodeWith p to s =
390276 L.Done _ v -> case to v of
391277 ISuccess a -> Right a
392278 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
279+ L.Fail _ _ msg -> Left ([], msg)
399280{-# INLINE eitherDecodeWith #-}
400281
401282eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
@@ -448,11 +329,12 @@ data SP = SP !Integer {-# UNPACK #-}!Int
448329
449330decimal0 :: Parser Integer
450331decimal0 = do
451− let zero = 48
332+ let step a w = a * 10 + fromIntegral (w - zero)
333+ zero = 48
452334 digits <- A.takeWhile1 isDigit_w8
453335 if B.length digits > 1 && B.unsafeHead digits == zero
454336 then fail "leading zero"
455− else return (bsToInteger digits)
337+ else return (B.foldl' step 0 digits)
456338
457339-- | Parse a JSON number.
458340scientific :: Parser Scientific
@@ -485,53 +367,3 @@ scientific = do
485367 fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>
486368 return (Sci.scientific signedCoeff e)
487369{-# 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+1−2
@@ -1,5 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Data.Aeson.Parser.Time
42 (
53 run
@@ -11,6 +9,7 @@ module Data.Aeson.Parser.Time
119 , zonedTime
1210 ) where
1311
12+import Prelude ()
1413import Prelude.Compat
1514
1615import Data.Attoparsec.Text (Parser)
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+62−53
@@ -116,7 +116,8 @@ module Data.Aeson.TH
116116 , mkLiftParseJSON2
117117 ) where
118118
119−import Prelude.Compat
119+import Prelude ()
120+import Prelude.Compat hiding (exp)
120121
121122import Control.Applicative ((<|>))
122123import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
@@ -135,15 +136,22 @@ import Data.Map (Map)
135136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
136137import qualified Data.Monoid as Monoid
137138import Data.Set (Set)
139+#if MIN_VERSION_template_haskell(2,8,0)
138140import Language.Haskell.TH hiding (Arity)
141+#else
142+import Language.Haskell.TH
143+#endif
139144import Language.Haskell.TH.Datatype
145+#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
146+import Language.Haskell.TH.Lib (starK)
147+#endif
140148#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
141149import Language.Haskell.TH.Syntax (mkNameG_tc)
142150#endif
143151import Text.Printf (printf)
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)
154+import qualified Data.HashMap.Strict as H (lookup, toList)
147155import qualified Data.List.NonEmpty as NE (length, reverse)
148156import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
149157import qualified Data.Semigroup as Semigroup (Option(..))
@@ -152,6 +160,8 @@ import qualified Data.Text as T (Text, pack, unpack)
152160import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
153161import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
154162
163+{-# ANN module "Hlint: ignore Reduce duplication" #-}
164+
155165--------------------------------------------------------------------------------
156166-- Convenience
157167--------------------------------------------------------------------------------
@@ -325,13 +335,13 @@ consToValue :: ToJSONFun
325335consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
326336 ++ "Not a single constructor given!"
327337
328−consToValue target jc opts instTys cons = do
338+consToValue target jc opts vars cons = do
329339 value <- newName "value"
330340 tjs <- newNameList "_tj" $ arityInt jc
331341 tjls <- newNameList "_tjl" $ arityInt jc
332342 let zippedTJs = zip tjs tjls
333343 interleavedTJs = interleave tjs tjls
334− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
344+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
335345 tvMap = M.fromList $ zip lastTyVars zippedTJs
336346 lamE (map varP $ interleavedTJs ++ [value]) $
337347 caseE (varE value) (matches tvMap)
@@ -663,13 +673,13 @@ consFromJSON :: JSONClass
663673consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
664674 ++ "Not a single constructor given!"
665675
666−consFromJSON jc tName opts instTys cons = do
676+consFromJSON jc tName opts vars cons = do
667677 value <- newName "value"
668678 pjs <- newNameList "_pj" $ arityInt jc
669679 pjls <- newNameList "_pjl" $ arityInt jc
670680 let zippedPJs = zip pjs pjls
671681 interleavedPJs = interleave pjs pjls
672− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
682+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
673683 tvMap = M.fromList $ zip lastTyVars zippedPJs
674684 lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
675685
@@ -922,32 +932,12 @@ parseRecord :: JSONClass
922932 -> Name
923933 -> [Name]
924934 -> Name
925− -> Bool
926935 -> ExpQ
927−parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
928− (if rejectUnknownFields opts
929− then infixApp checkUnknownRecords [|(>>)|]
930− else id) $
936+parseRecord jc tvMap argTys opts tName conName fields obj =
931937 foldl' (\a b -> infixApp a [|(<*>)|] b)
932938 (infixApp (conE conName) [|(<$>)|] x)
933939 xs
934940 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− ]
951941 x:xs = [ [|lookupField|]
952942 `appE` dispatchParseJSON jc conName tvMap argTy
953943 `appE` litE (stringL $ show tName)
@@ -1022,7 +1012,7 @@ parseArgs jc tvMap tName opts
10221012 , constructorFields = argTys }
10231013 (Left (_, obj)) = do
10241014 argTys' <- mapM resolveTypeSynonyms argTys
1025− parseRecord jc tvMap argTys' opts tName conName fields obj True
1015+ parseRecord jc tvMap argTys' opts tName conName fields obj
10261016parseArgs jc tvMap tName opts
10271017 info@ConstructorInfo { constructorName = conName
10281018 , constructorVariant = RecordConstructor fields
@@ -1037,7 +1027,7 @@ parseArgs jc tvMap tName opts
10371027 argTys' <- mapM resolveTypeSynonyms argTys
10381028 caseE (varE valName)
10391029 [ match (conP 'Object [varP obj]) (normalB $
1040− parseRecord jc tvMap argTys' opts tName conName fields obj False) []
1030+ parseRecord jc tvMap argTys' opts tName conName fields obj) []
10411031 , matchFailed tName conName "Object"
10421032 ]
10431033
@@ -1220,27 +1210,23 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]
12201210deriveJSONClass consFuns jc opts name = do
12211211 info <- reifyDatatype name
12221212 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
1213+ DatatypeInfo { datatypeContext = ctxt
1214+ , datatypeName = parentName
1215+ , datatypeVars = vars
1216+ , datatypeVariant = variant
1217+ , datatypeCons = cons
12321218 } -> do
12331219 (instanceCxt, instanceType)
1234− <- buildTypeInstance parentName jc ctxt instTys variant
1220+ <- buildTypeInstance parentName jc ctxt vars variant
12351221 (:[]) <$> instanceD (return instanceCxt)
12361222 (return instanceType)
1237− (methodDecs parentName instTys cons)
1223+ (methodDecs parentName vars cons)
12381224 where
12391225 methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
1240− methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->
1226+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->
12411227 funD (jsonFunValName jf (arity jc))
12421228 [ clause []
1243− (normalB $ jfMaker jc parentName opts instTys cons)
1229+ (normalB $ jfMaker jc parentName opts vars cons)
12441230 []
12451231 ]
12461232
@@ -1256,21 +1242,17 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q
12561242mkFunCommon consFun jc opts name = do
12571243 info <- reifyDatatype name
12581244 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
1245+ DatatypeInfo { datatypeContext = ctxt
1246+ , datatypeName = parentName
1247+ , datatypeVars = vars
1248+ , datatypeVariant = variant
1249+ , datatypeCons = cons
12681250 } -> do
12691251 -- We force buildTypeInstance here since it performs some checks for whether
12701252 -- or not the provided datatype's kind matches the derived method's
12711253 -- typeclass, and produces errors if it can't.
1272− !_ <- buildTypeInstance parentName jc ctxt instTys variant
1273− consFun jc parentName opts instTys cons
1254+ !_ <- buildTypeInstance parentName jc ctxt vars variant
1255+ consFun jc parentName opts vars cons
12741256
12751257dispatchFunByType :: JSONClass
12761258 -> JSONFun
@@ -1603,13 +1585,21 @@ type TyVarMap = Map Name (Name, Name)
16031585-- | Returns True if a Type has kind *.
16041586hasKindStar :: Type -> Bool
16051587hasKindStar VarT{} = True
1588+#if MIN_VERSION_template_haskell(2,8,0)
16061589hasKindStar (SigT _ StarT) = True
1590+#else
1591+hasKindStar (SigT _ StarK) = True
1592+#endif
16071593hasKindStar _ = False
16081594
16091595-- Returns True is a kind is equal to *, or if it is a kind variable.
16101596isStarOrVar :: Kind -> Bool
1597+#if MIN_VERSION_template_haskell(2,8,0)
16111598isStarOrVar StarT = True
16121599isStarOrVar VarT{} = True
1600+#else
1601+isStarOrVar StarK = True
1602+#endif
16131603isStarOrVar _ = False
16141604
16151605-- Generate a list of fresh names with a common prefix, and numbered suffixes.
@@ -1667,7 +1657,9 @@ isTyFamily (ConT n) = do
16671657#else
16681658 FamilyI (FamilyD TypeFam _ _ _) _ -> True
16691659#endif
1660+#if MIN_VERSION_template_haskell(2,9,0)
16701661 FamilyI ClosedTypeFamilyD{} _ -> True
1662+#endif
16711663 _ -> False
16721664isTyFamily _ = return False
16731665
@@ -1695,7 +1687,9 @@ mentionsName = go
16951687 go :: Type -> [Name] -> Bool
16961688 go (AppT t1 t2) names = go t1 names || go t2 names
16971689 go (SigT t _k) names = go t names
1690+#if MIN_VERSION_template_haskell(2,8,0)
16981691 || go _k names
1692+#endif
16991693 go (VarT n) names = n `elem` names
17001694 go _ _ = False
17011695
@@ -1751,14 +1745,23 @@ uncurryTy t = ([], t :| [])
17511745
17521746-- | Like uncurryType, except on a kind level.
17531747uncurryKind :: Kind -> NonEmpty Kind
1748+#if MIN_VERSION_template_haskell(2,8,0)
17541749uncurryKind = snd . uncurryTy
1750+#else
1751+uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
1752+uncurryKind k = k :| []
1753+#endif
17551754
17561755createKindChain :: Int -> Kind
17571756createKindChain = go starK
17581757 where
17591758 go :: Kind -> Int -> Kind
17601759 go k 0 = k
1760+#if MIN_VERSION_template_haskell(2,8,0)
17611761 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)
1762+#else
1763+ go k !n = go (ArrowK StarK k) (n - 1)
1764+#endif
17621765
17631766-- | Makes a string literal expression from a constructor's name.
17641767conNameExp :: Options -> ConstructorInfo -> Q Exp
@@ -1812,7 +1815,11 @@ canEtaReduce remaining dropped =
18121815-------------------------------------------------------------------------------
18131816
18141817applySubstitutionKind :: Map Name Kind -> Type -> Type
1818+#if MIN_VERSION_template_haskell(2,8,0)
18151819applySubstitutionKind = applySubstitution
1820+#else
1821+applySubstitutionKind _ t = t
1822+#endif
18161823
18171824substNameWithKind :: Name -> Kind -> Type -> Type
18181825substNameWithKind n k = applySubstitutionKind (M.singleton n k)
@@ -1976,7 +1983,9 @@ data StarKindStatus = NotKindStar
19761983canRealizeKindStar :: Type -> StarKindStatus
19771984canRealizeKindStar t = case t of
19781985 _ | hasKindStar t -> KindStar
1986+#if MIN_VERSION_template_haskell(2,8,0)
19791987 SigT _ (VarT k) -> IsKindVar k
1988+#endif
19801989 _ -> NotKindStar
19811990
19821991-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
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+2−22
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21-- |
32-- Module: Data.Aeson.Types
43-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -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,7 +36,6 @@ module Data.Aeson.Types
3836 , ToJSON(..)
3937 , KeyValue(..)
4038 , modifyFailure
41− , prependFailure
4239 , parserThrowError
4340 , parserCatchError
4441
@@ -53,12 +50,6 @@ module Data.Aeson.Types
5350 , coerceFromJSONKeyFunction
5451 , mapFromJSONKeyFunction
5552
56− -- *** Generic keys
57− , GToJSONKey()
58− , genericToJSONKey
59− , GFromJSONKey()
60− , genericFromJSONKey
61−
6253 -- ** Liftings to unary and binary type constructors
6354 , FromJSON1(..)
6455 , parseJSON1
@@ -90,6 +81,7 @@ module Data.Aeson.Types
9081 , withObject
9182 , withText
9283 , withArray
84+ , withNumber
9385 , withScientific
9486 , withBool
9587 , withEmbeddedJSON
@@ -124,7 +116,6 @@ module Data.Aeson.Types
124116 , sumEncoding
125117 , unwrapUnaryRecords
126118 , tagSingleConstructors
127− , rejectUnknownFields
128119
129120 -- ** Options utilities
130121 , SumEncoding(..)
@@ -132,20 +123,9 @@ module Data.Aeson.Types
132123 , camelTo2
133124 , defaultOptions
134125 , 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
147126 ) where
148127
128+import Prelude ()
149129import Prelude.Compat
150130
151131import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs)
Data/Aeson/Types/Class.hs+3−7
@@ -4,8 +4,8 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE GADTs #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE NoImplicitPrelude #-}
87{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
99
1010-- |
1111-- Module: Data.Aeson.Types.Class
@@ -58,11 +58,6 @@ module Data.Aeson.Types.Class
5858 , fromJSONKeyCoerce
5959 , coerceFromJSONKeyFunction
6060 , mapFromJSONKeyFunction
61− -- ** Generic keys
62− , GToJSONKey()
63− , genericToJSONKey
64− , GFromJSONKey()
65− , genericFromJSONKey
6661 -- * Object key-value pairs
6762 , KeyValue(..)
6863
@@ -75,6 +70,7 @@ module Data.Aeson.Types.Class
7570 , withObject
7671 , withText
7772 , withArray
73+ , withNumber
7874 , withScientific
7975 , withBool
8076 , withEmbeddedJSON
@@ -83,7 +79,6 @@ module Data.Aeson.Types.Class
8379 , fromJSON
8480 , ifromJSON
8581 , typeMismatch
86− , unexpected
8782 , parseField
8883 , parseFieldMaybe
8984 , parseFieldMaybe'
@@ -97,6 +92,7 @@ module Data.Aeson.Types.Class
9792 , (.!=)
9893 ) where
9994
95+import Prelude ()
10096
10197import Data.Aeson.Types.FromJSON
10298import Data.Aeson.Types.Generic (One, Zero)
Data/Aeson/Types/FromJSON.hs+424−805
@@ -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,6 +52,7 @@ module Data.Aeson.Types.FromJSON
5252 , withObject
5353 , withText
5454 , withArray
55+ , withNumber
5556 , withScientific
5657 , withBool
5758 , withEmbeddedJSON
@@ -60,14 +61,12 @@ module Data.Aeson.Types.FromJSON
6061 , fromJSON
6162 , ifromJSON
6263 , typeMismatch
63− , unexpected
6464 , parseField
6565 , parseFieldMaybe
6666 , parseFieldMaybe'
6767 , explicitParseField
6868 , explicitParseFieldMaybe
6969 , explicitParseFieldMaybe'
70− , parseIndexedJSON
7170 -- ** Operators
7271 , (.:)
7372 , (.:?)
@@ -78,16 +77,18 @@ module Data.Aeson.Types.FromJSON
7877 , parseOptionalFieldWith
7978 ) where
8079
80+import Prelude ()
8181import Prelude.Compat
8282
83−import Control.Applicative ((<|>), Const(..), liftA2)
84−import Control.Monad (zipWithM)
83+import Control.Applicative ((<|>), Const(..))
84+import Control.Monad ((<=<), zipWithM)
8585import Data.Aeson.Internal.Functions (mapKey)
8686import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
8787import Data.Aeson.Types.Generic
8888import Data.Aeson.Types.Internal
89+import Data.Attoparsec.Number (Number(..))
8990import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)
91+import Data.Fixed (Fixed, HasResolution)
9192import Data.Functor.Compose (Compose(..))
9293import Data.Functor.Identity (Identity(..))
9394import Data.Functor.Product (Product(..))
@@ -96,21 +97,18 @@ import Data.Hashable (Hashable(..))
9697import Data.Int (Int16, Int32, Int64, Int8)
9798import Data.List.NonEmpty (NonEmpty(..))
9899import Data.Maybe (fromMaybe)
99−import Data.Semigroup ((<>))
100+import Data.Monoid ((<>))
100101import Data.Proxy (Proxy(..))
101102import Data.Ratio ((%), Ratio)
102−import Data.Scientific (Scientific, base10Exponent)
103+import Data.Scientific (Scientific)
103104import Data.Tagged (Tagged(..))
104105import Data.Text (Text, pack, unpack)
105106import 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)
107+import Data.Time.Format (parseTime)
108+import Data.Time.Locale.Compat (defaultTimeLocale)
110109import Data.Traversable as Tr (sequence)
111110import Data.Vector (Vector)
112111import Data.Version (Version, parseVersion)
113−import Data.Void (Void)
114112import Data.Word (Word16, Word32, Word64, Word8)
115113import Foreign.Storable (Storable)
116114import Foreign.C.Types (CTime (..))
@@ -118,9 +116,9 @@ import GHC.Generics
118116import Numeric.Natural (Natural)
119117import Text.ParserCombinators.ReadP (readP_to_S)
120118import Unsafe.Coerce (unsafeCoerce)
119+import qualified Data.Aeson.Compat as Compat
121120import qualified Data.Aeson.Parser.Time as Time
122121import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124122import qualified Data.DList as DList
125123import qualified Data.HashMap.Strict as H
126124import qualified Data.HashSet as HashSet
@@ -143,20 +141,18 @@ import qualified Data.Vector.Primitive as VP
143141import qualified Data.Vector.Storable as VS
144142import qualified Data.Vector.Unboxed as VU
145143
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
144+#ifndef HAS_COERCIBLE
145+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
154146#endif
155−import qualified Data.Primitive.PrimArray as PM
156−#endif
157−
158147
148+#if HAS_COERCIBLE
159149import Data.Coerce (Coercible, coerce)
150+coerce' :: Coercible a b => a -> b
151+coerce' = coerce
152+#else
153+coerce' :: a -> b
154+coerce' = unsafeCoerce
155+#endif
160156
161157parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162158parseIndexedJSON p idx value = p value <?> Index idx
@@ -165,7 +161,7 @@ parseIndexedJSON p idx value = p value <?> Index idx
165161parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
166162parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
167163 where
168− p = withArray "(k, v)" $ \ab ->
164+ p = withArray "(k,v)" $ \ab ->
169165 let n = V.length ab
170166 in if n == 2
171167 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
@@ -177,34 +173,43 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
177173parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
178174parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
179175
176+scientificToNumber :: Scientific -> Number
177+scientificToNumber s
178+ | e < 0 = D $ Scientific.toRealFloat s
179+ | otherwise = I $ c * 10 ^ e
180+ where
181+ e = Scientific.base10Exponent s
182+ c = Scientific.coefficient s
183+{-# INLINE scientificToNumber #-}
184+
180185parseRealFloat :: 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)
186+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
187+parseRealFloat _ Null = pure (0/0)
188+parseRealFloat expected v = typeMismatch expected v
184189{-# INLINE parseRealFloat #-}
185190
186−parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a
187−parseIntegralFromScientific s =
191+parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a
192+parseIntegralFromScientific expected s =
188193 case Scientific.floatingOrInteger s :: Either Double a of
189194 Right x -> pure x
190− Left _ -> fail $ "unexpected floating number " ++ show s
195+ Left _ -> fail $ "expected " ++ expected ++ ", encountered floating number " ++ show s
191196{-# INLINE parseIntegralFromScientific #-}
192197
193198parseIntegral :: Integral a => String -> Value -> Parser a
194−parseIntegral name =
195− prependContext name . withBoundedScientific' parseIntegralFromScientific
199+parseIntegral expected =
200+ withScientific expected $ parseIntegralFromScientific expected
196201{-# INLINE parseIntegral #-}
197202
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)
203+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a
204+parseBoundedIntegralFromScientific expected s = maybe
205+ (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)
201206 pure
202207 (Scientific.toBoundedInteger s)
203208{-# INLINE parseBoundedIntegralFromScientific #-}
204209
205210parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
206−parseBoundedIntegral name =
207− prependContext name . withScientific' parseBoundedIntegralFromScientific
211+parseBoundedIntegral expected =
212+ withScientific expected $ parseBoundedIntegralFromScientific expected
208213{-# INLINE parseBoundedIntegral #-}
209214
210215parseScientificText :: Text -> Parser Scientific
@@ -214,20 +219,13 @@ parseScientificText
214219 . T.encodeUtf8
215220
216221parseIntegralText :: 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)
222+parseIntegralText expected t =
223+ parseScientificText t >>= parseIntegralFromScientific expected
225224{-# INLINE parseIntegralText #-}
226225
227226parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
228−parseBoundedIntegralText name t =
229− prependContext name $
230− parseScientificText t >>= parseBoundedIntegralFromScientific
227+parseBoundedIntegralText expected t =
228+ parseScientificText t >>= parseBoundedIntegralFromScientific expected
231229
232230parseOptionalFieldWith :: (Value -> Parser (Maybe a))
233231 -> Object -> Text -> Parser (Maybe a)
@@ -287,21 +285,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
287285--
288286-- The basic ways to signal a failed conversion are as follows:
289287--
290−-- * 'fail' yields a custom error message: it is the recommended way of
291−-- reporting a failure;
292−--
293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
294−-- use it when the error is meant to be caught by some @('<|>')@;
288+-- * 'empty' and 'mzero' work, but are terse and uninformative;
295289--
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.
290+-- * 'fail' yields a custom error message;
300291--
301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
302−-- error messages.
292+-- * 'typeMismatch' produces an informative message for cases when the
293+-- value encountered is not of the expected type.
303294--
304−-- An example type and instance using 'typeMismatch' and 'prependFailure':
295+-- An example type and instance using 'typeMismatch':
305296--
306297-- @
307298-- \-- Allow ourselves to write 'Text' literals.
@@ -315,15 +306,13 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
315306-- '<*>' v '.:' \"y\"
316307--
317308-- \-- We do not expect a non-'Object' value here.
318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
309+-- \-- We could use 'mzero' to fail, but 'typeMismatch'
319310-- \-- gives a much more informative error message.
320−-- 'parseJSON' invalid =
321−-- 'prependFailure' "parsing Coord failed, "
322−-- ('typeMismatch' \"Object\" invalid)
311+-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid
323312-- @
324313--
325314-- For this common case of only being concerned with a single
326−-- type of JSON value, the functions 'withObject', 'withScientific', etc.
315+-- type of JSON value, the functions 'withObject', 'withNumber', etc.
327316-- are provided. Their use is to be preferred when possible, since
328317-- they are more terse. Using 'withObject', we can rewrite the above instance
329318-- (assuming the same language extension and data type) as:
@@ -362,7 +351,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
362351-- @
363352--
364353-- The default implementation will be equivalent to
365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
354+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different
366355-- options, you can customize the generic decoding by defining:
367356--
368357-- @
@@ -380,11 +369,13 @@ class FromJSON a where
380369 parseJSON = genericParseJSON defaultOptions
381370
382371 parseJSONList :: Value -> Parser [a]
383− parseJSONList = withArray "[]" $ \a ->
384− zipWithM (parseIndexedJSON parseJSON) [0..]
372+ parseJSONList (Array a)
373+ = zipWithM (parseIndexedJSON parseJSON) [0..]
385374 . V.toList
386375 $ a
387376
377+ parseJSONList v = typeMismatch "[a]" v
378+
388379-------------------------------------------------------------------------------
389380-- Classes and types for map keys
390381-------------------------------------------------------------------------------
@@ -396,16 +387,6 @@ class FromJSON a where
396387-- > newtype SomeId = SomeId { getSomeId :: Text }
397388-- > deriving (Eq,Ord,Hashable,FromJSONKey)
398389--
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−-- @
409390class FromJSONKey a where
410391 -- | Strategy for parsing the key of a map-like container.
411392 fromJSONKey :: FromJSONKeyFunction a
@@ -428,7 +409,11 @@ class FromJSONKey a where
428409-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429410-- can be inspected, but cannot be constructed.
430411data CoerceText a where
412+#if HAS_COERCIBLE
431413 CoerceText :: Coercible Text a => CoerceText a
414+#else
415+ CoerceText :: CoerceText a
416+#endif
432417
433418-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434419-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +433,7 @@ data FromJSONKeyFunction a
448433
449434-- | Only law abiding up to interpretation
450435instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
436+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452437 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453438 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454439 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +447,9 @@ instance Functor FromJSONKeyFunction where
462447--
463448-- On pre GHC 7.8 this is unconstrainted function.
464449fromJSONKeyCoerce ::
450+#if HAS_COERCIBLE
465451 Coercible Text a =>
452+#endif
466453 FromJSONKeyFunction a
467454fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
468455
@@ -470,91 +457,60 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
470457--
471458-- See note on 'fromJSONKeyCoerce'.
472459coerceFromJSONKeyFunction ::
460+#if HAS_COERCIBLE
473461 Coercible a b =>
462+#endif
474463 FromJSONKeyFunction a -> FromJSONKeyFunction b
464+#if HAS_COERCIBLE
475465coerceFromJSONKeyFunction = coerce
466+#else
467+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
468+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
469+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
470+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
471+#endif
476472
477473{-# RULES
478474 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479475 fmap id x = x
480476 #-}
477+#if HAS_COERCIBLE
481478{-# RULES
482479 "FromJSONKeyCoerce: fmap coerce" forall x .
483480 fmap coerce x = coerceFromJSONKeyFunction x
484481 #-}
482+#endif
485483
486484-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487485mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
488486mapFromJSONKeyFunction = fmap
489487
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−
519488-------------------------------------------------------------------------------
520489-- Functions needed for documentation
521490-------------------------------------------------------------------------------
522491
523492-- | Fail parsing due to a type mismatch, with a descriptive message.
524493--
525−-- The following wrappers should generally be prefered:
526−-- 'withObject', 'withArray', 'withText', 'withBool'.
527−--
528−-- ==== Error message example
494+-- Example usage:
529495--
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\"@).
496+-- @
497+-- instance FromJSON Coord where
498+-- parseJSON ('Object' v) = {- type matches, life is good -}
499+-- parseJSON wat = 'typeMismatch' \"Coord\" wat
500+-- @
501+typeMismatch :: String -- ^ The name of the type you are trying to parse.
535502 -> Value -- ^ The actual value encountered.
536503 -> Parser a
537504typeMismatch 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"
505+ fail $ "expected " ++ expected ++ ", encountered " ++ name
506+ where
507+ name = case actual of
508+ Object _ -> "Object"
509+ Array _ -> "Array"
510+ String _ -> "String"
511+ Number _ -> "Number"
512+ Bool _ -> "Boolean"
513+ Null -> "Null"
558514
559515-------------------------------------------------------------------------------
560516-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -635,8 +591,9 @@ class FromJSON2 f where
635591 -> (Value -> Parser b)
636592 -> (Value -> Parser [b])
637593 -> 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)
594+ liftParseJSONList2 fa ga fb gb v = case v of
595+ Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
596+ _ -> typeMismatch "[a]" v
640597
641598-- | Lift the standard 'parseJSON' function through the type constructor.
642599parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
@@ -650,7 +607,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
650607-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
651608listParser :: (Value -> Parser a) -> Value -> Parser [a]
652609listParser f (Array xs) = fmap V.toList (V.mapM f xs)
653−listParser _ v = typeMismatch "Array" v
610+listParser _ v = typeMismatch "[a]" v
654611{-# INLINE listParser #-}
655612
656613-------------------------------------------------------------------------------
@@ -668,137 +625,57 @@ instance (FromJSON a) => FromJSON [a] where
668625-- Functions
669626-------------------------------------------------------------------------------
670627
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"
628+-- | @'withObject' expected f value@ applies @f@ to the 'Object' when @value@
629+-- is an 'Object' and fails using @'typeMismatch' expected@ otherwise.
686630withObject :: String -> (Object -> Parser a) -> Value -> Parser a
687−withObject _ f (Object obj) = f obj
688−withObject name _ v = prependContext name (typeMismatch "Object" v)
631+withObject _ f (Object obj) = f obj
632+withObject expected _ v = typeMismatch expected v
689633{-# INLINE withObject #-}
690634
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"
635+-- | @'withText' expected f value@ applies @f@ to the 'Text' when @value@ is a
636+-- 'String' and fails using @'typeMismatch' expected@ otherwise.
698637withText :: String -> (Text -> Parser a) -> Value -> Parser a
699−withText _ f (String txt) = f txt
700−withText name _ v = prependContext name (typeMismatch "String" v)
638+withText _ f (String txt) = f txt
639+withText expected _ v = typeMismatch expected v
701640{-# INLINE withText #-}
702641
703642-- | @'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"
643+-- an 'Array' and fails using @'typeMismatch' expected@ otherwise.
710644withArray :: String -> (Array -> Parser a) -> Value -> Parser a
711−withArray _ f (Array arr) = f arr
712−withArray name _ v = prependContext name (typeMismatch "Array" v)
645+withArray _ f (Array arr) = f arr
646+withArray expected _ v = typeMismatch expected v
713647{-# INLINE withArray #-}
714648
715−-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
716−-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'
649+-- | @'withNumber' expected f value@ applies @f@ to the 'Number' when @value@
650+-- is a 'Number' and fails using @'typeMismatch' expected@ otherwise.
651+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
652+withNumber expected f = withScientific expected (f . scientificToNumber)
653+{-# INLINE withNumber #-}
654+{-# DEPRECATED withNumber "Use withScientific instead" #-}
655+
656+-- | @'withScientific' expected f value@ applies @f@ to the 'Scientific' number
657+-- when @value@ is a 'Number' and fails using @'typeMismatch' expected@
717658-- 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"
728659withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
729−withScientific _ f (Number scientific) = f scientific
730−withScientific name _ v = prependContext name (typeMismatch "Number" v)
660+withScientific _ f (Number scientific) = f scientific
661+withScientific expected _ v = typeMismatch expected v
731662{-# INLINE withScientific #-}
732663
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−
782664-- | @'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"
665+-- 'Bool' and fails using @'typeMismatch' expected@ otherwise.
789666withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
790−withBool _ f (Bool arr) = f arr
791−withBool name _ v = prependContext name (typeMismatch "Boolean" v)
667+withBool _ f (Bool arr) = f arr
668+withBool expected _ v = typeMismatch expected v
792669{-# INLINE withBool #-}
793670
794671-- | Decode a nested JSON-encoded string.
795−withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
672+withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a
796673withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
674+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
798675 where
799676 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800677 eitherFormatError = either (Left . uncurry formatError) Right
801−withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)
678+withEmbeddedJSON name _ v = typeMismatch name v
802679{-# INLINE withEmbeddedJSON #-}
803680
804681-- | Convert a value from JSON, failing if the types do not match.
@@ -863,7 +740,7 @@ parseFieldMaybe' = (.:!)
863740-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864741explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865742explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
743+ Nothing -> fail $ "key " ++ show key ++ " not present"
867744 Just v -> p v <?> Key key
868745{-# INLINE explicitParseField #-}
869746
@@ -903,47 +780,11 @@ pmval .!= val = fromMaybe val <$> pmval
903780-- Generic parseJSON
904781-------------------------------------------------------------------------------
905782
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−
911783instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
912784 -- Meta-information, which is not handled elsewhere, is just added to the
913785 -- parsed value:
914786 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
915787
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−
947788instance (FromJSON a) => GFromJSON arity (K1 i a) where
948789 -- Constant values are decoded using their FromJSON instance:
949790 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -958,499 +799,347 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
958799 -- FromJSON1 instance:
959800 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
960801
961−instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
962− -- If an occurrence of the last type parameter is nested inside two
963− -- composed types, it is decoded by using the outermost type's FromJSON1
964− -- instance to generically decode the innermost type:
965− 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)
802+instance GFromJSON arity U1 where
803+ -- Empty constructors are expected to be encoded as an empty array:
804+ gParseJSON _opts _ v
805+ | isEmptyArray v = pure U1
806+ | otherwise = typeMismatch "unit constructor (U1)" v
985807
986−-- | Single constructor.
987808instance ( ConsFromJSON arity a
988809 , AllNullary (C1 c a) allNullary
989810 , ParseSum arity (C1 c a) allNullary
990− , Constructor c
991− ) => GFromJSON' arity (C1 c a) where
811+ ) => GFromJSON arity (D1 d (C1 c a)) where
992812 -- The option 'tagSingleConstructors' determines whether to wrap
993813 -- a single-constructor type.
994− gParseJSON' p@(_ :* opts :* _)
814+ gParseJSON opts fargs
995815 | 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
816+ = fmap M1
817+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
818+ . parseSum opts fargs
819+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
820+
821+instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
822+ -- Constructors need to be decoded differently depending on whether they're
823+ -- a record or not. This distinction is made by consParseJSON:
824+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs
825+
826+instance ( FromProduct arity a, FromProduct arity b
827+ , ProductSize a, ProductSize b
828+ ) => GFromJSON arity (a :*: b) where
829+ -- Products are expected to be encoded to an array. Here we check whether we
830+ -- got an array of the same size as the product, then parse each of the
831+ -- product's elements using parseProduct:
832+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->
833+ let lenArray = V.length arr
834+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
835+ productSize in
836+ if lenArray == lenProduct
837+ then parseProduct opts fargs arr 0 lenProduct
838+ else fail $ "When expecting a product of " ++ show lenProduct ++
839+ " values, encountered an Array of " ++ show lenArray ++
840+ " elements instead"
841+
842+instance ( AllNullary (a :+: b) allNullary
843+ , ParseSum arity (a :+: b) allNullary
844+ ) => GFromJSON arity (a :+: b) where
1006845 -- If all constructors of a sum datatype are nullary and the
1007846 -- 'allNullaryToStringTag' option is set they are expected to be
1008847 -- 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
848+ gParseJSON opts fargs =
849+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
850+ Parser ((a :+: b) d))
851+ . parseSum opts fargs
852+
853+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
854+ -- If an occurrence of the last type parameter is nested inside two
855+ -- composed types, it is decoded by using the outermost type's FromJSON1
856+ -- instance to generically decode the innermost type:
857+ gParseJSON opts fargs =
858+ let gpj = gParseJSON opts fargs in
859+ fmap Comp1 . liftParseJSON gpj (listParser gpj)
1013860
1014861--------------------------------------------------------------------------------
1015862
1016863class ParseSum arity f allNullary where
1017− parseSum :: TypeName :* Options :* FromArgs arity a
1018− -> Value
1019− -> Tagged allNullary (Parser (f a))
864+ parseSum :: Options -> FromArgs arity a
865+ -> Value -> Tagged allNullary (Parser (f a))
1020866
1021−instance ( ConstructorNames f
1022− , SumFromString f
867+instance ( SumFromString f
1023868 , FromPair arity f
1024869 , FromTaggedObject arity f
1025870 , FromUntaggedValue arity f
1026871 ) => ParseSum arity f True where
1027− parseSum p@(tname :* opts :* _)
1028− | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
1029− | otherwise = Tagged . parseNonAllNullarySum p
872+ parseSum opts fargs
873+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
874+ | otherwise = Tagged . parseNonAllNullarySum opts fargs
1030875
1031−instance ( ConstructorNames f
1032− , FromPair arity f
876+instance ( FromPair arity f
1033877 , FromTaggedObject arity f
1034878 , FromUntaggedValue arity f
1035879 ) => ParseSum arity f False where
1036− parseSum p = Tagged . parseNonAllNullarySum p
880+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1037881
1038882--------------------------------------------------------------------------------
1039883
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])
884+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
885+parseAllNullarySum opts = withText "Text" $ \key ->
886+ maybe (notFound key) return $
887+ parseSumFromString opts key
1062888
1063889class SumFromString f where
1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
890+ parseSumFromString :: Options -> Text -> Maybe (f a)
1065891
1066892instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
1067893 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
1068894 (R1 <$> parseSumFromString opts key)
1069895
1070896instance (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
897+ parseSumFromString opts key | key == name = Just $ M1 U1
898+ | otherwise = Nothing
899+ where
900+ name = pack $ constructorTagModifier opts $
901+ conName (undefined :: t c U1 p)
1111902
1112903--------------------------------------------------------------------------------
1113−parseNonAllNullarySum :: forall f c arity.
1114− ( FromPair arity f
904+
905+parseNonAllNullarySum :: ( FromPair arity f
1115906 , FromTaggedObject arity f
1116907 , FromUntaggedValue arity f
1117− , ConstructorNames f
1118− ) => TypeName :* Options :* FromArgs arity c
908+ ) => Options -> FromArgs arity c
1119909 -> Value -> Parser (f c)
1120−parseNonAllNullarySum p@(tname :* opts :* _) =
910+parseNonAllNullarySum opts fargs =
1121911 case sumEncoding opts of
1122912 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])
913+ withObject "Object" $ \obj -> do
914+ tag <- obj .: pack tagFieldName
915+ fromMaybe (notFound tag) $
916+ parseFromTaggedObject opts fargs contentsFieldName obj tag
1133917
1134918 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
919+ withObject "Object" $ \obj ->
920+ case H.toList obj of
921+ [pair@(tag, _)] -> fromMaybe (notFound tag) $
922+ parsePair opts fargs pair
923+ _ -> fail "Object doesn't have a single field"
1145924
1146925 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
926+ withArray "Array" $ \arr ->
927+ if V.length arr == 2
928+ then case V.unsafeIndex arr 0 of
929+ String tag -> fromMaybe (notFound tag) $
930+ parsePair opts fargs (tag, V.unsafeIndex arr 1)
931+ _ -> fail "First element is not a String"
932+ else fail "Array doesn't have 2 elements"
1161933
1162− UntaggedValue -> parseUntaggedValue p
1163− where
1164− failWith_ = failWithCTags tname (constructorTagModifier opts)
934+ UntaggedValue -> parseUntaggedValue opts fargs
1165935
1166936--------------------------------------------------------------------------------
1167937
1168938class 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))
939+ parseFromTaggedObject :: Options -> FromArgs arity a
940+ -> String -> Object
941+ -> Text -> Maybe (Parser (f a))
1175942
1176943instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1177944 FromTaggedObject arity (a :+: b) where
1178− parseFromTaggedObject p obj =
1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>
1180− (fmap R1 <$> parseFromTaggedObject p obj)
945+ parseFromTaggedObject opts fargs contentsFieldName obj tag =
946+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
947+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1181948
1182−instance ( IsRecord f isRecord
1183− , FromTaggedObject' arity f isRecord
949+instance ( FromTaggedObject' arity f
1184950 , Constructor c
1185951 ) => 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)
952+ parseFromTaggedObject opts fargs contentsFieldName obj tag
953+ | tag == name = Just $ M1 <$> parseFromTaggedObject'
954+ opts fargs contentsFieldName obj
955+ | otherwise = Nothing
956+ where
957+ name = pack $ constructorTagModifier opts $
958+ conName (undefined :: t c f p)
1195959
1196960--------------------------------------------------------------------------------
1197961
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
962+class FromTaggedObject' arity f where
963+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String
964+ -> Object -> Parser (f a)
965+
966+class FromTaggedObject'' arity f isRecord where
967+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
968+ -> Object -> Tagged isRecord (Parser (f a))
1216969
1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where
1218− -- Nullary constructors don't need a contents field
1219− parseFromTaggedObject' _ _ = Tagged (pure U1)
970+instance ( IsRecord f isRecord
971+ , FromTaggedObject'' arity f isRecord
972+ ) => FromTaggedObject' arity f where
973+ parseFromTaggedObject' opts fargs contentsFieldName =
974+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
975+ parseFromTaggedObject'' opts fargs contentsFieldName
976+
977+instance (FromRecord arity f) => FromTaggedObject'' arity f True where
978+ parseFromTaggedObject'' opts fargs _ =
979+ Tagged . parseRecord opts fargs Nothing
980+
981+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
982+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
983+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))
984+
985+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
986+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)
1220987
1221988--------------------------------------------------------------------------------
1222989
1223−-- | Constructors need to be decoded differently depending on whether they're
1224−-- a record or not. This distinction is made by 'ConsParseJSON'.
1225990class ConsFromJSON arity f where
1226− consParseJSON
1227− :: ConName :* TypeName :* Options :* FromArgs arity a
1228− -> Value -> Parser (f a)
991+ consParseJSON :: Options -> FromArgs arity a
992+ -> Value -> Parser (f a)
1229993
1230994class ConsFromJSON' arity f isRecord where
1231− consParseJSON'
1232− :: ConName :* TypeName :* Options :* FromArgs arity a
1233− -> Value -> Tagged isRecord (Parser (f a))
995+ consParseJSON' :: Options -> FromArgs arity a
996+ -> Maybe Text -- ^ A dummy label
997+ -- (Nothing to use proper label)
998+ -> Value -> Tagged isRecord (Parser (f a))
1234999
12351000instance ( IsRecord f isRecord
12361001 , ConsFromJSON' arity f isRecord
12371002 ) => ConsFromJSON arity f where
1238− consParseJSON p =
1239− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1240− . consParseJSON' p
1241−
1242−instance OVERLAPPING_
1243− ( GFromJSON arity a, RecordFromJSON arity (S1 s a)
1244− ) => ConsFromJSON' arity (S1 s a) True where
1245− consParseJSON' p@(cname :* tname :* opts :* fargs)
1246− | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1003+ consParseJSON opts fargs v = let
1004+ (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of
1005+ -- use a dummy object with a dummy label
1006+ (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")
1007+ _ ->(v,Nothing)
1008+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1009+ $ consParseJSON' opts fargs lab v2
12481010
1249−instance RecordFromJSON arity f => ConsFromJSON' arity f True where
1250− consParseJSON' p@(cname :* tname :* _) =
1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12521011
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)
1265−
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
1012+instance (FromRecord arity f) => ConsFromJSON' arity f True where
1013+ consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"
1014+ (parseRecord opts fargs mlab)
12701015
1271−instance (ProductFromJSON arity f, ProductSize f
1272− ) => ConsFromJSON' arity f False where
1273− consParseJSON' p = Tagged . productParseJSON0 p
1016+instance (GFromJSON arity f) => ConsFromJSON' arity f False where
1017+ consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs
12741018
12751019--------------------------------------------------------------------------------
12761020
1277−class FieldNames f where
1278− fieldNames :: f a -> [Text] -> [Text]
1021+class FromRecord arity f where
1022+ parseRecord :: Options -> FromArgs arity a
1023+ -> Maybe Text -- ^ A dummy label
1024+ -- (Nothing to use proper label)
1025+ -> Object -> Parser (f a)
12791026
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)) :)
1287−
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
1027+instance ( FromRecord arity a
1028+ , FromRecord arity b
1029+ ) => FromRecord arity (a :*: b) where
1030+ parseRecord opts fargs _ obj =
1031+ (:*:) <$> parseRecord opts fargs Nothing obj
1032+ <*> parseRecord opts fargs Nothing obj
13221033
13231034instance 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)
1035+ FromRecord arity (S1 s a) where
1036+ parseRecord opts fargs lab =
1037+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)
1038+ where
1039+ label = fromMaybe defLabel lab
1040+ defLabel = pack . fieldLabelModifier opts $
1041+ selName (undefined :: t s a p)
13311042
13321043instance 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)
1044+ FromRecord arity (S1 s (K1 i (Maybe a))) where
1045+ parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab
1046+ parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label
1047+ where
1048+ label = fieldLabelModifier opts $
1049+ selName (undefined :: t s (K1 i (Maybe a)) p)
13381050
13391051-- Parse an Option like a Maybe.
13401052instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1053+ FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
1054+ parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj
13431055 where
13441056 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13451057 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
13461058
13471059--------------------------------------------------------------------------------
13481060
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
1061+class FromProduct arity f where
1062+ parseProduct :: Options -> FromArgs arity a
13711063 -> Array -> Int -> Int
13721064 -> Parser (f a)
13731065
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
1066+instance ( FromProduct arity a
1067+ , FromProduct arity b
1068+ ) => FromProduct arity (a :*: b) where
1069+ parseProduct opts fargs arr ix len =
1070+ (:*:) <$> parseProduct opts fargs arr ix lenL
1071+ <*> parseProduct opts fargs arr ixR lenR
13801072 where
13811073 lenL = len `unsafeShiftR` 1
13821074 ixR = ix + lenL
13831075 lenR = len - lenL
13841076
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
1077+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1078+ parseProduct opts fargs arr ix _ =
1079+ gParseJSON opts fargs $ V.unsafeIndex arr ix
13881080
13891081--------------------------------------------------------------------------------
13901082
13911083class 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))
1084+ parsePair :: Options -> FromArgs arity a
1085+ -> Pair -> Maybe (Parser (f a))
13961086
13971087instance ( FromPair arity a
13981088 , FromPair arity b
13991089 ) => FromPair arity (a :+: b) where
1400− parsePair p pair =
1401− (fmap L1 <$> parsePair p pair) <|>
1402− (fmap R1 <$> parsePair p pair)
1090+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1091+ (fmap R1 <$> parsePair opts fargs pair)
14031092
14041093instance ( Constructor c
1094+ , GFromJSON arity a
14051095 , ConsFromJSON arity a
14061096 ) => FromPair arity (C1 c a) where
1407− parsePair (tag :* p@(_ :* opts :* _)) v
1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
1097+ parsePair opts fargs (tag, value)
1098+ | tag == tag' = Just $ gParseJSON opts fargs value
14091099 | otherwise = Nothing
1410− where
1411− tag' = pack $ constructorTagModifier opts cname
1412− cname = conName (undefined :: M1 _i c _a _p)
1100+ where
1101+ tag' = pack $ constructorTagModifier opts $
1102+ conName (undefined :: t c a p)
14131103
14141104--------------------------------------------------------------------------------
14151105
14161106class FromUntaggedValue arity f where
1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1418− -> Value
1419− -> Parser (f a)
1107+ parseUntaggedValue :: Options -> FromArgs arity a
1108+ -> Value -> Parser (f a)
14201109
14211110instance
14221111 ( FromUntaggedValue arity a
14231112 , FromUntaggedValue arity b
14241113 ) => FromUntaggedValue arity (a :+: b)
14251114 where
1426− parseUntaggedValue p value =
1427− L1 <$> parseUntaggedValue p value <|>
1428− R1 <$> parseUntaggedValue p value
1115+ parseUntaggedValue opts fargs value =
1116+ L1 <$> parseUntaggedValue opts fargs value <|>
1117+ R1 <$> parseUntaggedValue opts fargs value
14291118
14301119instance OVERLAPPABLE_
1431− ( ConsFromJSON arity a
1432− , Constructor c
1120+ ( GFromJSON arity a
1121+ , ConsFromJSON arity a
14331122 ) => FromUntaggedValue arity (C1 c a)
14341123 where
1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1436− where
1437− cname = conName (undefined :: M1 _i c _f _p)
1124+ parseUntaggedValue = gParseJSON
14381125
14391126instance OVERLAPPING_
14401127 ( Constructor c )
14411128 => FromUntaggedValue arity (C1 c U1)
14421129 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
1130+ parseUntaggedValue opts _ (String s)
1131+ | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1132+ pure $ M1 U1
1133+ | otherwise =
1134+ fail $ "Invalid tag: " ++ unpack s
1135+ parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1136+
1137+
1138+--------------------------------------------------------------------------------
1139+
1140+notFound :: Text -> Parser a
1141+notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1142+{-# INLINE notFound #-}
14541143
14551144-------------------------------------------------------------------------------
14561145-- Instances
@@ -1508,20 +1197,17 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
15081197 parseJSON = parseJSON2
15091198 {-# INLINE parseJSON #-}
15101199
1511−instance FromJSON Void where
1512− parseJSON _ = fail "Cannot parse Void"
1513− {-# INLINE parseJSON #-}
1200+
15141201
15151202instance FromJSON Bool where
1516− parseJSON (Bool b) = pure b
1517− parseJSON v = typeMismatch "Bool" v
1203+ parseJSON = withBool "Bool" pure
15181204 {-# INLINE parseJSON #-}
15191205
15201206instance FromJSONKey Bool where
15211207 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
15221208 "true" -> pure True
15231209 "false" -> pure False
1524− _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"
1210+ _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t
15251211
15261212instance FromJSON Ordering where
15271213 parseJSON = withText "Ordering" $ \s ->
@@ -1529,30 +1215,25 @@ instance FromJSON Ordering where
15291215 "LT" -> return LT
15301216 "EQ" -> return EQ
15311217 "GT" -> return GT
1532− _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++
1533− " (expected \"LT\", \"EQ\", or \"GT\")"
1218+ _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""
15341219
15351220instance FromJSON () where
15361221 parseJSON = withArray "()" $ \v ->
15371222 if V.null v
15381223 then pure ()
1539− else prependContext "()" $ fail "expected an empty array"
1224+ else fail "Expected an empty array"
15401225 {-# INLINE parseJSON #-}
15411226
15421227instance FromJSON Char where
1543− parseJSON = withText "Char" parseChar
1228+ parseJSON = withText "Char" $ \t ->
1229+ if T.compareLength t 1 == EQ
1230+ then pure $ T.head t
1231+ else fail "Expected a string of length 1"
15441232 {-# INLINE parseJSON #-}
15451233
1546− parseJSONList (String s) = pure (T.unpack s)
1547− parseJSONList v = typeMismatch "String" v
1234+ parseJSONList = withText "String" $ pure . T.unpack
15481235 {-# INLINE parseJSONList #-}
15491236
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−
15561237instance FromJSON Double where
15571238 parseJSON = parseRealFloat "Double"
15581239 {-# INLINE parseJSON #-}
@@ -1564,6 +1245,12 @@ instance FromJSONKey Double where
15641245 "-Infinity" -> pure (negate 1/0)
15651246 _ -> Scientific.toRealFloat <$> parseScientificText t
15661247
1248+instance FromJSON Number where
1249+ parseJSON (Number s) = pure $ scientificToNumber s
1250+ parseJSON Null = pure (D (0/0))
1251+ parseJSON v = typeMismatch "Number" v
1252+ {-# INLINE parseJSON #-}
1253+
15671254instance FromJSON Float where
15681255 parseJSON = parseRealFloat "Float"
15691256 {-# INLINE parseJSON #-}
@@ -1576,30 +1263,17 @@ instance FromJSONKey Float where
15761263 _ -> Scientific.toRealFloat <$> parseScientificText t
15771264
15781265instance (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.
1266+ parseJSON = withObject "Rational" $ \obj ->
1267+ (%) <$> obj .: "numerator"
1268+ <*> obj .: "denominator"
1269+ {-# INLINE parseJSON #-}
1270+
1271+-- | /WARNING:/ Only parse fixed-precision numbers from trusted input
1272+-- since an attacker could easily fill up the memory of the target
1273+-- system by specifying a scientific number with a big exponent like
1274+-- @1e1000000000@.
16011275instance HasResolution a => FromJSON (Fixed a) where
1602− parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
1276+ parseJSON = withScientific "Fixed" $ pure . realToFrac
16031277 {-# INLINE parseJSON #-}
16041278
16051279instance FromJSON Int where
@@ -1609,10 +1283,10 @@ instance FromJSON Int where
16091283instance FromJSONKey Int where
16101284 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
16111285
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.
1286+-- | /WARNING:/ Only parse Integers from trusted input since an
1287+-- attacker could easily fill up the memory of the target system by
1288+-- specifying a scientific number with a big exponent like
1289+-- @1e1000000000@.
16161290instance FromJSON Integer where
16171291 parseJSON = parseIntegral "Integer"
16181292 {-# INLINE parseJSON #-}
@@ -1622,20 +1296,19 @@ instance FromJSONKey Integer where
16221296
16231297instance FromJSON Natural where
16241298 parseJSON value = do
1625− integer <- parseIntegral "Natural" value
1626− parseNatural integer
1299+ integer :: Integer <- parseIntegral "Natural" value
1300+ if integer < 0 then
1301+ fail $ "expected Natural, encountered negative number " <> show integer
1302+ else
1303+ pure $ fromIntegral integer
16271304
16281305instance FromJSONKey Natural where
16291306 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
1307+ integer :: Integer <- parseIntegralText "Natural" text
1308+ if integer < 0 then
1309+ fail $ "expected Natural, encountered negative number " <> show integer
1310+ else
1311+ pure $ fromIntegral integer
16391312
16401313instance FromJSON Int8 where
16411314 parseJSON = parseBoundedIntegral "Int8"
@@ -1732,17 +1405,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack
17321405 where
17331406 go [(v,[])] = return v
17341407 go (_ : xs) = go xs
1735− go _ = fail "parsing Version failed"
1408+ go _ = fail "could not parse Version"
17361409
17371410-------------------------------------------------------------------------------
17381411-- semigroups NonEmpty
17391412-------------------------------------------------------------------------------
17401413
17411414instance FromJSON1 NonEmpty where
1742− liftParseJSON p _ = withArray "NonEmpty" $
1415+ liftParseJSON p _ = withArray "NonEmpty a" $
17431416 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
17441417 where
1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1418+ ne [] = fail "Expected a NonEmpty but got an empty list"
17461419 ne (x:xs) = pure (x :| xs)
17471420 {-# INLINE liftParseJSON #-}
17481421
@@ -1763,7 +1436,7 @@ instance FromJSON Scientific where
17631436-------------------------------------------------------------------------------
17641437
17651438instance FromJSON1 DList.DList where
1766− liftParseJSON p _ = withArray "DList" $
1439+ liftParseJSON p _ = withArray "DList a" $
17671440 fmap DList.fromList .
17681441 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
17691442 {-# INLINE liftParseJSON #-}
@@ -1840,7 +1513,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
18401513 inr = "InR"
18411514
18421515 liftParseJSON _ _ _ = fail $
1843− "parsing Sum failed, expected an object with a single property " ++
1516+ "expected an object with a single property " ++
18441517 "where the property key should be either " ++
18451518 "\"InL\" or \"InR\""
18461519 {-# INLINE liftParseJSON #-}
@@ -1854,7 +1527,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
18541527-------------------------------------------------------------------------------
18551528
18561529instance FromJSON1 Seq.Seq where
1857− liftParseJSON p _ = withArray "Seq" $
1530+ liftParseJSON p _ = withArray "Seq a" $
18581531 fmap Seq.fromList .
18591532 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
18601533 {-# INLINE liftParseJSON #-}
@@ -1888,13 +1561,13 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where
18881561
18891562instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
18901563 liftParseJSON p _ = case fromJSONKey of
1891− FromJSONKeyCoerce _ -> withObject "Map" $
1564+ FromJSONKeyCoerce _-> withObject "Map k v" $
18921565 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1893− FromJSONKeyText f -> withObject "Map" $
1566+ FromJSONKeyText f -> withObject "Map k v" $
18941567 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1895− FromJSONKeyTextParser f -> withObject "Map" $
1568+ FromJSONKeyTextParser f -> withObject "Map k v" $
18961569 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 ->
1570+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
18981571 fmap M.fromList . Tr.sequence .
18991572 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
19001573 {-# INLINE liftParseJSON #-}
@@ -1922,18 +1595,18 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where
19221595
19231596instance FromJSON UUID.UUID where
19241597 parseJSON = withText "UUID" $
1925− maybe (fail "invalid UUID") pure . UUID.fromText
1598+ maybe (fail "Invalid UUID") pure . UUID.fromText
19261599
19271600instance FromJSONKey UUID.UUID where
19281601 fromJSONKey = FromJSONKeyTextParser $
1929− maybe (fail "invalid UUID") pure . UUID.fromText
1602+ maybe (fail "Invalid UUID") pure . UUID.fromText
19301603
19311604-------------------------------------------------------------------------------
19321605-- vector
19331606-------------------------------------------------------------------------------
19341607
19351608instance FromJSON1 Vector where
1936− liftParseJSON p _ = withArray "Vector" $
1609+ liftParseJSON p _ = withArray "Vector a" $
19371610 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
19381611 {-# INLINE liftParseJSON #-}
19391612
@@ -1947,14 +1620,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe
19471620{-# INLINE vectorParseJSON #-}
19481621
19491622instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1950− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"
1623+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
19511624
19521625instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1953− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"
1626+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
19541627 {-# INLINE parseJSON #-}
19551628
19561629instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1957− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
1630+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
19581631 {-# INLINE parseJSON #-}
19591632
19601633-------------------------------------------------------------------------------
@@ -1968,13 +1641,13 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
19681641
19691642instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
19701643 liftParseJSON p _ = case fromJSONKey of
1971− FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $
1644+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $
19721645 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1973− FromJSONKeyText f -> withObject "HashMap" $
1646+ FromJSONKeyText f -> withObject "HashMap k v" $
19741647 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1975− FromJSONKeyTextParser f -> withObject "HashMap" $
1648+ FromJSONKeyTextParser f -> withObject "HashMap k v" $
19761649 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 ->
1650+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
19781651 fmap H.fromList . Tr.sequence .
19791652 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
19801653 where
@@ -1997,33 +1670,11 @@ instance FromJSON DotNetTime where
19971670 parseJSON = withText "DotNetTime" $ \t ->
19981671 let (s,m) = T.splitAt (T.length t - 5) t
19991672 t' = T.concat [s,".",m]
2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1673+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
20011674 Just d -> pure (DotNetTime d)
20021675 _ -> fail "could not parse .NET time"
20031676 {-# INLINE parseJSON #-}
20041677
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−
20271678-------------------------------------------------------------------------------
20281679-- time
20291680-------------------------------------------------------------------------------
@@ -2074,56 +1725,22 @@ instance FromJSONKey UTCTime where
20741725 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
20751726
20761727
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.
1728+-- | /WARNING:/ Only parse lengths of time from trusted input
1729+-- since an attacker could easily fill up the memory of the target
1730+-- system by specifying a scientific number with a big exponent like
1731+-- @1e1000000000@.
20811732instance FromJSON NominalDiffTime where
2082− parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
1733+ parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
20831734 {-# INLINE parseJSON #-}
20841735
20851736
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.
1737+-- | /WARNING:/ Only parse lengths of time from trusted input
1738+-- since an attacker could easily fill up the memory of the target
1739+-- system by specifying a scientific number with a big exponent like
1740+-- @1e1000000000@.
20901741instance FromJSON DiffTime where
2091− parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
2092− {-# INLINE parseJSON #-}
2093−
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
1742+ parseJSON = withScientific "DiffTime" $ pure . realToFrac
1743+ {-# INLINE parseJSON #-}
21271744
21281745-------------------------------------------------------------------------------
21291746-- base Monoid/Semigroup
@@ -2245,15 +1862,14 @@ instance FromJSON a => FromJSON (Semigroup.Option a) where
22451862
22461863instance FromJSON1 Proxy where
22471864 {-# INLINE liftParseJSON #-}
2248− liftParseJSON _ _ = fromNull "Proxy" Proxy
1865+ liftParseJSON _ _ Null = pure Proxy
1866+ liftParseJSON _ _ v = typeMismatch "Proxy" v
22491867
22501868instance FromJSON (Proxy a) where
22511869 {-# INLINE parseJSON #-}
2252− parseJSON = fromNull "Proxy" Proxy
1870+ parseJSON Null = pure Proxy
1871+ parseJSON v = typeMismatch "Proxy" v
22531872
2254−fromNull :: String -> a -> Value -> Parser a
2255−fromNull _ a Null = pure a
2256−fromNull c _ v = prependContext c (typeMismatch "Null" v)
22571873
22581874instance FromJSON2 Tagged where
22591875 liftParseJSON2 _ _ p _ = fmap Tagged . p
@@ -2280,7 +1896,10 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
22801896instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
22811897
22821898instance FromJSONKey Char where
2283− fromJSONKey = FromJSONKeyTextParser parseChar
1899+ fromJSONKey = FromJSONKeyTextParser $ \t ->
1900+ if T.length t == 1
1901+ then return (T.index t 0)
1902+ else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)
22841903 fromJSONKeyList = FromJSONKeyText T.unpack
22851904
22861905instance (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+10−121
@@ -2,7 +2,6 @@
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE DeriveGeneric #-}
44{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE NoImplicitPrelude #-}
65{-# LANGUAGE Rank2Types #-}
76#if __GLASGOW_HASKELL__ >= 800
87-- a) THQ works on cross-compilers and unregisterised GHCs
@@ -45,12 +44,9 @@ module Data.Aeson.Types.Internal
4544 , parseEither
4645 , parseMaybe
4746 , modifyFailure
48− , prependFailure
4947 , parserThrowError
5048 , parserCatchError
5149 , formatError
52− , formatPath
53− , formatRelativePath
5450 , (<?>)
5551 -- * Constructors and accessors
5652 , object
@@ -64,14 +60,11 @@ module Data.Aeson.Types.Internal
6460 , sumEncoding
6561 , unwrapUnaryRecords
6662 , tagSingleConstructors
67− , rejectUnknownFields
6863 )
6964
7065 , SumEncoding(..)
71− , JSONKeyOptions(keyModifier)
7266 , defaultOptions
7367 , defaultTaggedObject
74− , defaultJSONKeyOptions
7568
7669 -- * Used for changing CamelCase names into something else.
7770 , camelTo
@@ -81,6 +74,7 @@ module Data.Aeson.Types.Internal
8174 , DotNetTime(..)
8275 ) where
8376
77+import Prelude ()
8478import Prelude.Compat
8579
8680import Control.Applicative (Alternative(..))
@@ -102,7 +96,6 @@ import Data.Time.Format (FormatTime)
10296import Data.Typeable (Typeable)
10397import Data.Vector (Vector)
10498import GHC.Generics (Generic)
105−import qualified Control.Monad as Monad
10699import qualified Control.Monad.Fail as Fail
107100import qualified Data.HashMap.Strict as H
108101import qualified Data.Scientific as S
@@ -121,7 +114,7 @@ data JSONPathElement = Key Text
121114 | Index {-# UNPACK #-} !Int
122115 -- ^ JSON path element of an index into an
123116 -- array, \"array[index]\".
124− deriving (Eq, Show, Typeable, Ord)
117+ deriving (Eq, Show, Typeable)
125118type JSONPath = [JSONPathElement]
126119
127120-- | The internal result of running a 'Parser'.
@@ -156,7 +149,7 @@ instance Functor Result where
156149 fmap _ (Error err) = Error err
157150 {-# INLINE fmap #-}
158151
159−instance Monad.Monad IResult where
152+instance Monad IResult where
160153 return = pure
161154 {-# INLINE return #-}
162155
@@ -164,16 +157,14 @@ instance Monad.Monad IResult where
164157 IError path err >>= _ = IError path err
165158 {-# INLINE (>>=) #-}
166159
167−#if !(MIN_VERSION_base(4,13,0))
168160 fail = Fail.fail
169161 {-# INLINE fail #-}
170−#endif
171162
172163instance Fail.MonadFail IResult where
173164 fail err = IError [] err
174165 {-# INLINE fail #-}
175166
176−instance Monad.Monad Result where
167+instance Monad Result where
177168 return = pure
178169 {-# INLINE return #-}
179170
@@ -181,10 +172,8 @@ instance Monad.Monad Result where
181172 Error err >>= _ = Error err
182173 {-# INLINE (>>=) #-}
183174
184−#if !(MIN_VERSION_base(4,13,0))
185175 fail = Fail.fail
186176 {-# INLINE fail #-}
187−#endif
188177
189178instance Fail.MonadFail Result where
190179 fail err = Error err
@@ -281,9 +270,7 @@ type Failure f r = JSONPath -> String -> f r
281270-- | Success continuation.
282271type Success a f r = a -> f r
283272
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.
273+-- | A JSON parser.
287274newtype Parser a = Parser {
288275 runParser :: forall f r.
289276 JSONPath
@@ -292,17 +279,14 @@ newtype Parser a = Parser {
292279 -> f r
293280 }
294281
295−instance Monad.Monad Parser where
282+instance Monad Parser where
296283 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks
297284 in runParser m path kf ks'
298285 {-# INLINE (>>=) #-}
299286 return = pure
300287 {-# INLINE return #-}
301−
302−#if !(MIN_VERSION_base(4,13,0))
303288 fail = Fail.fail
304289 {-# INLINE fail #-}
305−#endif
306290
307291instance Fail.MonadFail Parser where
308292 fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
@@ -345,7 +329,8 @@ instance Monoid (Parser a) where
345329apP :: Parser (a -> b) -> Parser a -> Parser b
346330apP d e = do
347331 b <- d
348− b <$> e
332+ a <- e
333+ return (b a)
349334{-# INLINE apP #-}
350335
351336-- | A JSON \"object\" (key\/value map).
@@ -461,17 +446,7 @@ parseEither m v = runParser (m v) [] onError Right
461446-- | Annotate an error message with a
462447-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.
463448formatError :: 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
449+formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
475450 where
476451 format :: String -> JSONPath -> String
477452 format pfx [] = pfx
@@ -537,15 +512,6 @@ modifyFailure :: (String -> String) -> Parser a -> Parser a
537512modifyFailure f (Parser p) = Parser $ \path kf ks ->
538513 p path (\p' m -> kf p' (f m)) ks
539514
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−
549515-- | Throw a parser error with an additional path.
550516--
551517-- @since 1.2.1.0
@@ -584,39 +550,6 @@ data Options = Options
584550 -- ^ If 'True' record fields with a 'Nothing' value will be
585551 -- omitted from the resulting object. If 'False' the resulting
586552 -- 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− -- @
620553 , sumEncoding :: SumEncoding
621554 -- ^ Specifies how to encode constructors of a sum datatype.
622555 , unwrapUnaryRecords :: Bool
@@ -625,14 +558,10 @@ data Options = Options
625558 , tagSingleConstructors :: Bool
626559 -- ^ Encode types with a single constructor as sums,
627560 -- 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.
632561 }
633562
634563instance Show Options where
635− show (Options f c a o s u t r) =
564+ show (Options f c a o s u t) =
636565 "Options {"
637566 ++ intercalate ", "
638567 [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -642,7 +571,6 @@ instance Show Options where
642571 , "sumEncoding = " ++ show s
643572 , "unwrapUnaryRecords = " ++ show u
644573 , "tagSingleConstructors = " ++ show t
645− , "rejectUnknownFields = " ++ show r
646574 ]
647575 ++ "}"
648576
@@ -686,33 +614,6 @@ data SumEncoding =
686614 -- contents of the constructor.
687615 deriving (Eq, Show)
688616
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−
716617-- | Default encoding 'Options':
717618--
718619-- @
@@ -724,7 +625,6 @@ data JSONKeyOptions = JSONKeyOptions
724625-- , 'sumEncoding' = 'defaultTaggedObject'
725626-- , 'unwrapUnaryRecords' = False
726627-- , 'tagSingleConstructors' = False
727−-- , 'rejectUnknownFields' = False
728628-- }
729629-- @
730630defaultOptions :: Options
@@ -736,7 +636,6 @@ defaultOptions = Options
736636 , sumEncoding = defaultTaggedObject
737637 , unwrapUnaryRecords = False
738638 , tagSingleConstructors = False
739− , rejectUnknownFields = False
740639 }
741640
742641-- | Default 'TaggedObject' 'SumEncoding' options:
@@ -753,16 +652,6 @@ defaultTaggedObject = TaggedObject
753652 , contentsFieldName = "contents"
754653 }
755654
756−-- | Default 'JSONKeyOptions':
757−--
758−-- @
759−-- defaultJSONKeyOptions = 'JSONKeyOptions'
760−-- { 'keyModifier' = 'id'
761−-- }
762−-- @
763−defaultJSONKeyOptions :: JSONKeyOptions
764−defaultJSONKeyOptions = JSONKeyOptions id
765−
766655-- | Converts from CamelCase to another lower case, interspersing
767656-- the character between all capital letters and their previous
768657-- entries, except those capital letters that appear together,
Data/Aeson/Types/ToJSON.hs+64−195
@@ -5,15 +5,20 @@
55{-# LANGUAGE FlexibleInstances #-}
66{-# 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"
1823#include "incoherent-compat.h"
1924
@@ -43,10 +48,6 @@ module Data.Aeson.Types.ToJSON
4348 , ToJSONKeyFunction(..)
4449 , toJSONKeyText
4550 , contramapToJSONKeyFunction
46−
47− , GToJSONKey()
48− , genericToJSONKey
49−
5051 -- * Object key-value pairs
5152 , KeyValue(..)
5253 , KeyValuePair(..)
@@ -57,6 +58,7 @@ module Data.Aeson.Types.ToJSON
5758 , listValue
5859 ) where
5960
61+import Prelude ()
6062import Prelude.Compat
6163
6264import Control.Applicative (Const(..))
@@ -64,35 +66,31 @@ import Control.Monad.ST (ST)
6466import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)
6567import Data.Aeson.Encoding.Internal ((>*<))
6668import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)
67−import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize)
69+import Data.Aeson.Types.Generic (AllNullary, False, IsRecord(..), One, ProductSize, Tagged2(..), True, Zero, productSize)
6870import Data.Aeson.Types.Internal
6971import Data.Attoparsec.Number (Number(..))
7072import Data.Bits (unsafeShiftR)
7173import Data.DList (DList)
72−import Data.Fixed (Fixed, HasResolution, Nano)
74+import Data.Fixed (Fixed, HasResolution)
7375import Data.Foldable (toList)
7476import Data.Functor.Compose (Compose(..))
75−import Data.Functor.Contravariant (Contravariant (..))
7677import Data.Functor.Identity (Identity(..))
7778import Data.Functor.Product (Product(..))
7879import Data.Functor.Sum (Sum(..))
7980import Data.Int (Int16, Int32, Int64, Int8)
8081import Data.List (intersperse)
8182import Data.List.NonEmpty (NonEmpty(..))
82−import Data.Semigroup ((<>))
83+import Data.Monoid ((<>))
8384import Data.Proxy (Proxy(..))
8485import Data.Ratio (Ratio, denominator, numerator)
8586import Data.Scientific (Scientific)
8687import Data.Tagged (Tagged(..))
8788import Data.Text (Text, pack)
8889import 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)
90+import Data.Time.Format (FormatTime, formatTime)
91+import Data.Time.Locale.Compat (defaultTimeLocale)
9392import Data.Vector (Vector)
9493import Data.Version (Version, showVersion)
95−import Data.Void (Void, absurd)
9694import Data.Word (Word16, Word32, Word64, Word8)
9795import Foreign.Storable (Storable)
9896import Foreign.C.Types (CTime (..))
@@ -100,6 +98,7 @@ import GHC.Generics
10098import Numeric.Natural (Natural)
10199import qualified Data.Aeson.Encoding as E
102100import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)
101+import qualified Data.ByteString as S
103102import qualified Data.ByteString.Lazy as L
104103import qualified Data.DList as DList
105104import qualified Data.HashMap.Strict as H
@@ -128,18 +127,16 @@ import qualified Data.Vector.Unboxed as VU
128127import qualified Data.Aeson.Encoding.Builder as EB
129128import qualified Data.ByteString.Builder as B
130129
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
130+#if !(MIN_VERSION_bytestring(0,10,0))
131+import Foreign.ForeignPtr (withForeignPtr)
132+import Foreign.Marshal.Utils (copyBytes)
133+import Foreign.Ptr (plusPtr)
134+import qualified Data.ByteString.Internal as S
135+import qualified Data.ByteString.Lazy.Internal as L
141136#endif
142137
138+{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
139+
143140toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
144141toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)
145142{-# INLINE toJSONPair #-}
@@ -267,7 +264,7 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
267264-- @
268265--
269266-- Previous versions of this library only had the 'toJSON' method. Adding
270−-- 'toEncoding' had two reasons:
267+-- 'toEncoding' had to reasons:
271268--
272269-- 1. toEncoding is more efficient for the common case that the output of
273270-- 'toJSON' is directly serialized to a @ByteString@.
@@ -338,13 +335,6 @@ instance KeyValue Pair where
338335 name .= value = (name, toJSON value)
339336 {-# INLINE (.=) #-}
340337
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−
348338-------------------------------------------------------------------------------
349339-- Classes and types for map keys
350340-------------------------------------------------------------------------------
@@ -402,7 +392,7 @@ instance KeyValue Object where
402392-- newtype wrapper around 'Text'. The recommended approach is to use
403393-- generalized newtype deriving:
404394--
405−-- > newtype RecordId = RecordId { getRecordId :: Text }
395+-- > newtype RecordId = RecordId { getRecordId :: Text}
406396-- > deriving (Eq,Ord,ToJSONKey)
407397--
408398-- Then we may write:
@@ -417,18 +407,8 @@ instance KeyValue Object where
417407--
418408-- It is possible to get the 'ToJSONKey' instance for free as we did
419409-- 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−--
410+-- and from 'Text' that does not require any escape sequences. So, in
411+-- this example, 'ToJSONKeyText' will be used instead of 'ToJSONKeyValue'.
432412-- The 'Show' instance can be used to help write 'ToJSONKey':
433413--
434414-- > instance ToJSONKey Color where
@@ -503,42 +483,16 @@ toJSONKeyTextEnc e = ToJSONKeyText tot e
503483 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
504484 tot = T.dropAround (== '"')
505485 . T.decodeLatin1
506− . L.toStrict
486+ . lazyToStrictByteString
507487 . E.encodingToLazyByteString
508488 . e
509489
510−instance Contravariant ToJSONKeyFunction where
511− contramap = contramapToJSONKeyFunction
512−
513490-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.
514491contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
515492contramapToJSONKeyFunction h x = case x of
516493 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)
517494 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)
518495
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−
542496-------------------------------------------------------------------------------
543497-- Lifings of FromJSON and ToJSON to unary and binary type constructors
544498-------------------------------------------------------------------------------
@@ -703,13 +657,11 @@ instance (ToJSON a) => ToJSON [a] where
703657instance OVERLAPPABLE_ (GToJSON enc arity a) => GToJSON enc arity (M1 i c a) where
704658 -- Meta-information, which is not handled elsewhere, is ignored:
705659 gToJSON opts targs = gToJSON opts targs . unM1
706− {-# INLINE gToJSON #-}
707660
708661instance GToJSON enc One Par1 where
709662 -- Direct occurrences of the last type parameter are encoded with the
710663 -- function passed in as an argument:
711664 gToJSON _opts (To1Args tj _) = tj . unPar1
712− {-# INLINE gToJSON #-}
713665
714666instance ( ConsToJSON enc arity a
715667 , AllNullary (C1 c a) allNullary
@@ -722,13 +674,11 @@ instance ( ConsToJSON enc arity a
722674 . sumToJSON opts targs
723675 . unM1
724676 | otherwise = consToJSON opts targs . unM1 . unM1
725− {-# INLINE gToJSON #-}
726677
727678instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where
728679 -- Constructors need to be encoded differently depending on whether they're
729680 -- a record or not. This distinction is made by 'consToJSON':
730681 gToJSON opts targs = consToJSON opts targs . unM1
731− {-# INLINE gToJSON #-}
732682
733683instance ( AllNullary (a :+: b) allNullary
734684 , SumToJSON enc arity (a :+: b) allNullary
@@ -739,7 +689,6 @@ instance ( AllNullary (a :+: b) allNullary
739689 -- strings. This distinction is made by 'sumToJSON':
740690 gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)
741691 . sumToJSON opts targs
742− {-# INLINE gToJSON #-}
743692
744693--------------------------------------------------------------------------------
745694-- Generic toJSON
@@ -748,27 +697,18 @@ instance ( AllNullary (a :+: b) allNullary
748697-- possible but makes error messages a bit harder to understand for missing
749698-- instances.
750699
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 #-}
756−
757700instance ToJSON a => GToJSON Value arity (K1 i a) where
758701 -- Constant values are encoded using their ToJSON instance:
759702 gToJSON _opts _ = toJSON . unK1
760− {-# INLINE gToJSON #-}
761703
762704instance ToJSON1 f => GToJSON Value One (Rec1 f) where
763705 -- Recursive occurrences of the last type parameter are encoded using their
764706 -- ToJSON1 instance:
765707 gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1
766− {-# INLINE gToJSON #-}
767708
768709instance GToJSON Value arity U1 where
769710 -- Empty constructors are encoded to an empty array:
770711 gToJSON _opts _ _ = emptyArray
771− {-# INLINE gToJSON #-}
772712
773713instance ( WriteProduct arity a, WriteProduct arity b
774714 , ProductSize a, ProductSize b
@@ -785,7 +725,6 @@ instance ( WriteProduct arity a, WriteProduct arity b
785725 where
786726 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
787727 productSize
788− {-# INLINE gToJSON #-}
789728
790729instance ( ToJSON1 f
791730 , GToJSON Value One g
@@ -797,7 +736,6 @@ instance ( ToJSON1 f
797736 gToJSON opts targs =
798737 let gtj = gToJSON opts targs in
799738 liftToJSON gtj (listValue gtj) . unComp1
800− {-# INLINE gToJSON #-}
801739
802740--------------------------------------------------------------------------------
803741-- Generic toEncoding
@@ -805,18 +743,15 @@ instance ( ToJSON1 f
805743instance ToJSON a => GToJSON Encoding arity (K1 i a) where
806744 -- Constant values are encoded using their ToJSON instance:
807745 gToJSON _opts _ = toEncoding . unK1
808− {-# INLINE gToJSON #-}
809746
810747instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where
811748 -- Recursive occurrences of the last type parameter are encoded using their
812749 -- ToEncoding1 instance:
813750 gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1
814− {-# INLINE gToJSON #-}
815751
816752instance GToJSON Encoding arity U1 where
817753 -- Empty constructors are encoded to an empty array:
818754 gToJSON _opts _ _ = E.emptyArray_
819− {-# INLINE gToJSON #-}
820755
821756instance ( EncodeProduct arity a
822757 , EncodeProduct arity b
@@ -826,7 +761,6 @@ instance ( EncodeProduct arity a
826761 -- the same size as the product and write the product's elements to it using
827762 -- 'encodeProduct':
828763 gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]
829− {-# INLINE gToJSON #-}
830764
831765instance ( ToJSON1 f
832766 , GToJSON Encoding One g
@@ -838,7 +772,6 @@ instance ( ToJSON1 f
838772 gToJSON opts targs =
839773 let gte = gToJSON opts targs in
840774 liftToEncoding gte (listEncoding gte) . unComp1
841− {-# INLINE gToJSON #-}
842775
843776--------------------------------------------------------------------------------
844777
@@ -927,7 +860,7 @@ instance ( IsRecord a isRecord
927860 ) => TaggedObject enc arity (C1 c a)
928861 where
929862 taggedObject opts targs tagFieldName contentsFieldName =
930− fromPairs . mappend tag . contents
863+ fromPairs . (tag <>) . contents
931864 where
932865 tag = tagFieldName `pair`
933866 (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
@@ -968,9 +901,6 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where
968901instance (Constructor c) => GetConName (C1 c a) where
969902 getConName = conName
970903
971−-- For genericToJSONKey
972−instance GetConName a => GetConName (D1 d a) where
973− getConName (M1 x) = getConName x
974904
975905--------------------------------------------------------------------------------
976906
@@ -1026,6 +956,7 @@ class ConsToJSON enc arity f where
1026956
1027957class ConsToJSON' enc arity f isRecord where
1028958 consToJSON' :: Options -> ToArgs enc arity a
959+ -> Bool -- ^ Are we a record with one field?
1029960 -> f a -> Tagged isRecord enc
1030961
1031962instance ( IsRecord f isRecord
@@ -1034,29 +965,23 @@ instance ( IsRecord f isRecord
1034965 where
1035966 consToJSON opts targs =
1036967 (unTagged :: Tagged isRecord enc -> enc)
1037− . consToJSON' opts targs
968+ . consToJSON' opts targs (isUnary (undefined :: f a))
1038969 {-# INLINE consToJSON #-}
1039970
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−
1051971instance ( RecordToPairs enc pairs arity f
1052972 , FromPairs enc pairs
973+ , GToJSON enc arity f
1053974 ) => ConsToJSON' enc arity f True
1054975 where
1055− consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs
976+ consToJSON' opts targs isUn =
977+ Tagged .
978+ case (isUn, unwrapUnaryRecords opts) of
979+ (True, True) -> gToJSON opts targs
980+ _ -> fromPairs . recordToPairs opts targs
1056981 {-# INLINE consToJSON' #-}
1057982
1058983instance GToJSON enc arity f => ConsToJSON' enc arity f False where
1059− consToJSON' opts targs = Tagged . gToJSON opts targs
984+ consToJSON' opts targs _ = Tagged . gToJSON opts targs
1060985 {-# INLINE consToJSON' #-}
1061986
1062987--------------------------------------------------------------------------------
@@ -1074,7 +999,7 @@ instance ( Monoid pairs
1074999 ) => RecordToPairs enc pairs arity (a :*: b)
10751000 where
10761001 recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =
1077− pairsOf a `mappend` pairsOf b
1002+ pairsOf a <> pairsOf b
10781003 where
10791004 pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs
10801005 pairsOf = recordToPairs opts targs
@@ -1145,12 +1070,10 @@ instance ( WriteProduct arity a
11451070 lenL = len `unsafeShiftR` 1
11461071 lenR = len - lenL
11471072 ixR = ix + lenL
1148− {-# INLINE writeProduct #-}
11491073
11501074instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where
11511075 writeProduct opts targs mv ix _ =
11521076 VM.unsafeWrite mv ix . gToJSON opts targs
1153− {-# INLINE writeProduct #-}
11541077
11551078--------------------------------------------------------------------------------
11561079
@@ -1168,11 +1091,9 @@ instance ( EncodeProduct arity a
11681091 encodeProduct opts targs (a :*: b) =
11691092 encodeProduct opts targs a >*<
11701093 encodeProduct opts targs b
1171− {-# INLINE encodeProduct #-}
11721094
11731095instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where
11741096 encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a
1175− {-# INLINE encodeProduct #-}
11761097
11771098--------------------------------------------------------------------------------
11781099
@@ -1276,13 +1197,6 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
12761197 toEncoding = toEncoding2
12771198 {-# INLINE toEncoding #-}
12781199
1279−instance ToJSON Void where
1280− toJSON = absurd
1281− {-# INLINE toJSON #-}
1282−
1283− toEncoding = absurd
1284− {-# INLINE toEncoding #-}
1285−
12861200
12871201instance ToJSON Bool where
12881202 toJSON = Bool
@@ -1966,32 +1880,6 @@ dotNetTime (DotNetTime t) = secs ++ formatMillis t ++ ")/"
19661880formatMillis :: (FormatTime t) => t -> String
19671881formatMillis = take 3 . formatTime defaultTimeLocale "%q"
19681882
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−
19951883-------------------------------------------------------------------------------
19961884-- time
19971885-------------------------------------------------------------------------------
@@ -2040,7 +1928,7 @@ stringEncoding :: Encoding' Text -> Value
20401928stringEncoding = String
20411929 . T.dropAround (== '"')
20421930 . T.decodeLatin1
2043− . L.toStrict
1931+ . lazyToStrictByteString
20441932 . E.encodingToLazyByteString
20451933{-# INLINE stringEncoding #-}
20461934
@@ -2060,50 +1948,6 @@ instance ToJSON DiffTime where
20601948 toEncoding = E.scientific . realToFrac
20611949 {-# INLINE toEncoding #-}
20621950
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−
21071951-------------------------------------------------------------------------------
21081952-- base Monoid/Semigroup
21091953-------------------------------------------------------------------------------
@@ -2847,6 +2691,31 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
28472691 toEncoding = toEncoding2
28482692 {-# INLINE toEncoding #-}
28492693
2694+-------------------------------------------------------------------------------
2695+-- pre-bytestring-0.10 compatibility
2696+-------------------------------------------------------------------------------
2697+
2698+{-# INLINE lazyToStrictByteString #-}
2699+lazyToStrictByteString :: L.ByteString -> S.ByteString
2700+#if MIN_VERSION_bytestring(0,10,0)
2701+lazyToStrictByteString = L.toStrict
2702+#else
2703+lazyToStrictByteString = packChunks
2704+
2705+-- packChunks is taken from the blaze-builder package.
2706+
2707+-- | Pack the chunks of a lazy bytestring into a single strict bytestring.
2708+packChunks :: L.ByteString -> S.ByteString
2709+packChunks lbs =
2710+ S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)
2711+ where
2712+ copyChunks L.Empty _pf = return ()
2713+ copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do
2714+ withForeignPtr fpbuf $ \pbuf ->
2715+ copyBytes pf (pbuf `plusPtr` o) l
2716+ copyChunks lbs' (pf `plusPtr` l)
2717+#endif
2718+
28502719--------------------------------------------------------------------------------
28512720
28522721-- | Wrap a list of pairs as an object.
HLint.hsnew file+10
@@ -0,0 +1,10 @@
1+module HLint.HLint where
2+
3+import "hint" HLint.Default
4+import "hint" HLint.Builtin.All
5+import "hint" HLint.Dollar
6+
7+ignore "Avoid lambda"
8+ignore "Eta reduce"
9+ignore "Functor law"
10+ignore "Use >=>"
Makefile+1−1
@@ -1,2 +1,2 @@
11lint:
2− ./run-hlint.sh --cpp-include include/ --cpp-file travis/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/
2+ hlint --cpp-include include/ --cpp-file .stack-work/dist/*/*Cabal-*/build/autogen/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+54−65
@@ -1,5 +1,5 @@
11name: aeson
2−version: 1.4.6.0
2+version: 1.2.3.0
33license: BSD3
44license-file: LICENSE
55category: Text, Web, JSON
@@ -21,6 +21,20 @@ 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:
@@ -42,7 +56,6 @@ extra-source-files:
4256 include/*.h
4357 tests/JSONTestSuite/test_parsing/*.json
4458 tests/JSONTestSuite/test_transform/*.json
45− tests/golden/*.expected
4659 pure/Data/Aeson/Parser/*.hs
4760
4861flag developer
@@ -76,7 +89,6 @@ library
7689 Data.Aeson.Text
7790 Data.Aeson.Types
7891 Data.Aeson.TH
79− Data.Aeson.QQ.Simple
8092
8193 Data.Aeson.Encoding.Internal
8294 Data.Aeson.Internal
@@ -88,6 +100,7 @@ library
88100 Data.Aeson.Encode
89101
90102 other-modules:
103+ Data.Aeson.Compat
91104 Data.Aeson.Encoding.Builder
92105 Data.Aeson.Internal.Functions
93106 Data.Aeson.Parser.Unescape
@@ -100,59 +113,43 @@ library
100113 Data.Attoparsec.Time
101114 Data.Attoparsec.Time.Internal
102115
103− -- GHC bundled libs
104116 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
117+ attoparsec >= 0.13.0.1,
118+ base >= 4.5 && < 5,
119+ base-compat >= 0.9.1 && < 0.10,
120+ containers >= 0.4.2,
121+ deepseq >= 1.3 && < 1.5,
122+ dlist >= 0.6,
123+ ghc-prim >= 0.2,
124+ hashable >= 1.1.2.0,
125+ scientific >= 0.3.4.7 && < 0.4,
126+ tagged >=0.8.3 && <0.9,
127+ template-haskell >= 2.7,
128+ text >= 1.1.1.0,
129+ th-abstraction >= 0.2.2 && < 0.3,
130+ time >= 1.1.1.4,
131+ time-locale-compat >= 0.1.1 && < 0.2,
132+ unordered-containers >= 0.2.5.0 && < 0.3,
133+ uuid-types >= 1.0.3 && <1.1,
134+ vector >= 0.8
121135
122− if !impl(ghc >= 8.6)
123− build-depends:
124− contravariant >=1.4.1 && <1.6
136+ if flag(bytestring-builder)
137+ build-depends: bytestring >= 0.9.2 && < 0.10.4,
138+ bytestring-builder >= 0.10.4 && < 1
139+ else
140+ build-depends: bytestring >= 0.10.4 && < 0.11
125141
126142 if !impl(ghc >= 8.0)
127143 -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9
128144 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,
145+ semigroups >= 0.18.2 && < 0.19,
146+ transformers >= 0.2.2.0,
147+ transformers-compat >= 0.3,
132148 fail == 4.9.*
133149
134150 if !impl(ghc >= 7.10)
135151 -- `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
152+ build-depends: nats >= 1 && < 1.2
156153
157154 ghc-options: -Wall
158155
@@ -195,49 +192,42 @@ test-suite tests
195192 Functions
196193 Instances
197194 Options
198− PropUtils
199195 Properties
200− PropertyGeneric
201− PropertyKeys
202− PropertyRoundTrip
203− PropertyRTFunctors
204− PropertyTH
205196 SerializationFormatSpec
206197 Types
207198 UnitTests
208199 UnitTests.NullaryConstructors
209200
210201 build-depends:
211− QuickCheck >= 2.10.0.1 && < 2.14,
202+ HUnit,
203+ QuickCheck >= 2.10.0.1 && < 2.11,
212204 aeson,
213205 integer-logarithms >= 1 && <1.1,
214206 attoparsec,
215207 base,
216208 base-compat,
217− base-orphans >= 0.5.3 && <0.9,
209+ base-orphans >= 0.5.3 && <0.7,
218210 base16-bytestring,
219211 containers,
220212 directory,
221213 dlist,
222− Diff >= 0.4 && < 0.5,
223214 filepath,
224− generic-deriving >= 1.10 && < 1.14,
215+ generic-deriving >= 1.10 && < 1.12,
225216 ghc-prim >= 0.2,
226217 hashable >= 1.2.4.0,
227218 scientific,
228219 tagged,
229220 template-haskell,
230− tasty,
231− tasty-golden,
232− tasty-hunit,
233− tasty-quickcheck,
221+ test-framework,
222+ test-framework-hunit,
223+ test-framework-quickcheck2,
234224 text,
235225 time,
236− time-compat,
226+ time-locale-compat,
237227 unordered-containers,
238228 uuid-types,
239229 vector,
240− quickcheck-instances >= 0.3.21 && <0.4
230+ quickcheck-instances >= 0.3.16
241231
242232 if flag(bytestring-builder)
243233 build-depends: bytestring >= 0.9 && < 0.10.4,
@@ -247,13 +237,12 @@ test-suite tests
247237
248238 if !impl(ghc >= 8.0)
249239 build-depends:
250− semigroups >= 0.18.2 && < 0.20,
240+ semigroups >= 0.18.2 && < 0.19,
251241 transformers >= 0.2.2.0,
252242 transformers-compat >= 0.3
253243
254244 if !impl(ghc >= 7.10)
255− build-depends: nats >=1 && <1.2,
256− void >=0.7.2 && <0.8
245+ build-depends: nats >=1 && <1.2
257246
258247 if impl(ghc >= 7.8)
259248 build-depends: hashable-time >= 0.2 && <0.3
attoparsec-iso8601/Data/Attoparsec/Time.hs+5−4
@@ -1,6 +1,6 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
32{-# LANGUAGE ScopedTypeVariables #-}
3+
44-- |
55-- Module: Data.Aeson.Parser.Time
66-- Copyright: (c) 2015-2016 Bryan O'Sullivan
@@ -21,6 +21,7 @@ module Data.Attoparsec.Time
2121 , zonedTime
2222 ) where
2323
24+import Prelude ()
2425import Prelude.Compat
2526
2627import Control.Applicative ((<|>))
@@ -41,9 +42,9 @@ import qualified Data.Time.LocalTime as Local
4142day :: Parser Day
4243day = do
4344 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"
45+ y <- decimal <* char '-'
46+ m <- twoDigits <* char '-'
47+ d <- twoDigits
4748 maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)
4849
4950-- | Parse a two-digit integer (e.g. day of month, hour).
attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs+18−21
@@ -1,5 +1,5 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
2+
33-- |
44-- Module: Data.Aeson.Internal.Time
55-- Copyright: (c) 2015-2016 Bryan O'Sullivan
@@ -17,48 +17,45 @@ module Data.Attoparsec.Time.Internal
1717 , toTimeOfDay64
1818 ) where
1919
20+import Prelude ()
2021import Prelude.Compat
2122
2223import Data.Int (Int64)
2324import Data.Time
2425import Unsafe.Coerce (unsafeCoerce)
2526
26−#if MIN_VERSION_time(1,6,0)
27−
28−import Data.Time.Clock (diffTimeToPicoseconds)
29−
30−#endif
27+#if MIN_VERSION_base(4,7,0)
3128
3229import Data.Fixed (Pico, Fixed(MkFixed))
3330
34−#if !MIN_VERSION_time(1,6,0)
31+toPico :: Integer -> Pico
32+toPico = MkFixed
3533
36−diffTimeToPicoseconds :: DiffTime -> Integer
37−diffTimeToPicoseconds = unsafeCoerce
34+fromPico :: Pico -> Integer
35+fromPico (MkFixed i) = i
3836
39−#endif
37+#else
38+
39+import Data.Fixed (Pico)
4040
4141toPico :: Integer -> Pico
42−toPico = MkFixed
42+toPico = unsafeCoerce
4343
4444fromPico :: Pico -> Integer
45−fromPico (MkFixed i) = i
45+fromPico = unsafeCoerce
46+
47+#endif
4648
4749-- | Like TimeOfDay, but using a fixed-width integer for seconds.
4850data TimeOfDay64 = TOD {-# UNPACK #-} !Int
4951 {-# UNPACK #-} !Int
5052 {-# UNPACK #-} !Int64
5153
52−posixDayLength :: DiffTime
53−posixDayLength = 86400
54−
5554diffTimeOfDay64 :: 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
55+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s
56+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000
57+ (m,s) = mp `quotRem` 60000000000000
58+ pico = unsafeCoerce t :: Integer
6259
6360toTimeOfDay64 :: TimeOfDay -> TimeOfDay64
6461toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))
attoparsec-iso8601/attoparsec-iso8601.cabal+3−3
@@ -1,5 +1,5 @@
11name: attoparsec-iso8601
2−version: 1.0.1.0
2+version: 1.0.0.0
33synopsis: Parsing of ISO 8601 dates, originally from aeson.
44description: Parsing of ISO 8601 dates, originally from aeson.
55license: BSD3
@@ -36,8 +36,8 @@ library
3636 Data.Attoparsec.Time
3737 build-depends:
3838 attoparsec >= 0.13.0.1,
39− base >= 4.7 && < 5,
40− base-compat >= 0.9.1 && < 0.12,
39+ base >= 4.5 && < 5,
40+ base-compat >= 0.9.1 && < 0.10,
4141 text >= 1.1.1.0,
4242 time >= 1.1.1.4
4343
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/AesonEncode.hs+2−2
@@ -1,13 +1,13 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
32{-# LANGUAGE OverloadedStrings #-}
43
54module Main (main) where
65
6+import Prelude ()
77import Prelude.Compat
88
99import Control.DeepSeq
10−import Control.Monad (forM_)
10+import Control.Monad
1111import Data.Aeson
1212import Data.Attoparsec.ByteString (IResult(..), parseWith)
1313import Data.Char (isDigit)
benchmarks/AesonFoldable.hs+1−1
@@ -1,10 +1,10 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21{-# LANGUAGE OverloadedStrings #-}
32
43module Main (main) where
54
65import Criterion.Main
76
7+import Prelude ()
88import Prelude.Compat
99
1010import Data.Foldable (toList)
benchmarks/AesonMap.hs+1−1
@@ -1,11 +1,11 @@
11{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
32{-# LANGUAGE RankNTypes #-}
43
54{-# OPTIONS_GHC -fno-warn-orphans #-}
65
76module Main (main) where
87
8+import Prelude ()
99import Prelude.Compat
1010
1111import Control.DeepSeq
benchmarks/AesonParse.hs+1−1
@@ -1,9 +1,9 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
32{-# LANGUAGE OverloadedStrings #-}
43
54module Main (main) where
65
6+import Prelude ()
77import Prelude.Compat
88
99import Data.Aeson
benchmarks/AesonTuples.hs+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Main (main) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Control.DeepSeq (deepseq)
benchmarks/Compare.hs+3−9
@@ -1,25 +1,21 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
31{-# LANGUAGE ScopedTypeVariables #-}
42
53module Main (main) where
64
5+import Prelude ()
76import Prelude.Compat
87
98import Compare.BufferBuilder ()
9+import Compare.JsonBuilder ()
1010import Criterion.Main
1111import Data.BufferBuilder.Json
12+import Data.Json.Builder
1213import Twitter
1314import Twitter.Manual ()
1415import Typed.Common
1516import qualified Data.Aeson as Aeson
1617import qualified Compare.JsonBench as JsonBench
1718
18−#ifdef MIN_VERSION_json_builder
19−import Data.Json.Builder
20−import Compare.JsonBuilder ()
21−#endif
22−
2319main :: IO ()
2420main =
2521 defaultMain [
@@ -27,9 +23,7 @@ main =
2723 bgroup "twitter" [
2824 bench "aeson" $ nf Aeson.encode twtr
2925 , bench "buffer-builder" $ nf encodeJson twtr
30−#ifdef MIN_VERSION_json_builder
3126 , bench "json-builder" $ nf toJsonLBS twtr
32−#endif
3327 ]
3428 , JsonBench.benchmarks
3529 ]
benchmarks/Compare/BufferBuilder.hs+3−2
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21{-# LANGUAGE OverloadedStrings #-}
32{-# LANGUAGE RecordWildCards #-}
43
@@ -7,11 +6,13 @@
76
87module Compare.BufferBuilder () where
98
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+9−18
@@ -1,18 +1,17 @@
1−{-# LANGUAGE CPP #-}
1+-- Adapted from a buffer-builder benchmark:
2+--
3+-- https://github.com/chadaustin/buffer-builder/blob/master/test.json
4+
25{-# LANGUAGE BangPatterns #-}
36{-# LANGUAGE MagicHash #-}
4−{-# LANGUAGE NoImplicitPrelude #-}
57{-# LANGUAGE OverloadedStrings #-}
68{-# LANGUAGE RecordWildCards #-}
79{-# LANGUAGE ScopedTypeVariables #-}
810
9−-- Adapted from a buffer-builder benchmark:
10−--
11−-- https://github.com/chadaustin/buffer-builder/blob/master/test.json
12−
1311module Compare.JsonBench (benchmarks) where
1412
15−import Prelude.Compat hiding ((<>))
13+import Prelude ()
14+import Prelude.Compat
1615
1716import Control.DeepSeq (NFData(..))
1817import Criterion
@@ -20,13 +19,9 @@ import Data.Aeson ((.:))
2019import Data.Monoid ((<>))
2120import Data.Text (Text)
2221import Typed.Common (load)
23−import qualified Control.Monad.Fail as Fail
2422import qualified Data.Aeson as Aeson
2523import qualified Data.BufferBuilder.Json as Json
26−
27−#ifdef MIN_VERSION_json_builder
2824import qualified Data.Json.Builder as JB
29−#endif
3025
3126data EyeColor = Green | Blue | Brown
3227 deriving (Eq, Show)
@@ -69,10 +64,10 @@ instance NFData Gender where rnf !_ = ()
6964instance NFData Fruit where rnf !_ = ()
7065
7166instance NFData Friend where
72− rnf Friend {..} = rnf fId `seq` rnf fName
67+ rnf Friend {..} = rnf fId `seq` rnf fName `seq` ()
7368
7469instance 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
70+ 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` ()
7671
7772eyeColorTable :: [(Text, EyeColor)]
7873eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]
@@ -83,7 +78,7 @@ genderTable = [("male", Male), ("female", Female)]
8378fruitTable :: [(Text, Fruit)]
8479fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]
8580
86−enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum
81+enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum
8782enumFromJson enumName table extract v = do
8883 s <- extract v
8984 case lookup s table of
@@ -273,7 +268,6 @@ instance Json.ToJson User where
273268 <> "greeting"# Json..=# uGreeting
274269 <> "favoriteFruit"# Json..=# uFavouriteFruit
275270
276−#ifdef MIN_VERSION_json_builder
277271---- json-builder instances ----
278272
279273instance JB.Value EyeColor where
@@ -325,7 +319,6 @@ instance JB.Value User where
325319 <> t "friends" `JB.row` uFriends
326320 <> t "greeting" `JB.row` uGreeting
327321 <> t "favoriteFruit" `JB.row` uFavouriteFruit
328−#endif
329322
330323benchmarks :: Benchmark
331324benchmarks = env (load "json-data/buffer-builder.json") $
@@ -333,7 +326,5 @@ benchmarks = env (load "json-data/buffer-builder.json") $
333326 bgroup "json-bench" [
334327 bench "aeson" $ nf Aeson.encode parsedUserList
335328 , bench "buffer-builder" $ nf Json.encodeJson parsedUserList
336−#ifdef MIN_VERSION_json_builder
337329 , bench "json-builder" $ nf JB.toJsonLBS parsedUserList
338−#endif
339330 ]
benchmarks/Compare/JsonBuilder.hs+3−2
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21{-# LANGUAGE RecordWildCards #-}
32
43{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -6,10 +5,12 @@
65
76module Compare.JsonBuilder () where
87
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+2−3
@@ -1,9 +1,8 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31{-# OPTIONS_GHC -fno-warn-orphans #-}
42
53module Main (main) where
64
5+import Prelude ()
76import Prelude.Compat
87
98import Blaze.ByteString.Builder (toLazyByteString)
@@ -27,7 +26,7 @@ instance (NFData v) => NFData (J.JSObject v) where
2726instance NFData J.JSValue where
2827 rnf J.JSNull = ()
2928 rnf (J.JSBool b) = rnf b
30− rnf (J.JSRational a b) = rnf a `seq` rnf b
29+ rnf (J.JSRational a b) = rnf a `seq` rnf b `seq` ()
3130 rnf (J.JSString s) = rnf (J.fromJSString s)
3231 rnf (J.JSArray lst) = rnf lst
3332 rnf (J.JSObject o) = rnf o
benchmarks/Dates.hs+2−2
@@ -1,7 +1,7 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
1+{-# OPTIONS_GHC -fsimpl-tick-factor=0 #-}
32module Main (main) where
43
4+import Prelude ()
55import Prelude.Compat
66
77import Criterion.Main
benchmarks/Escape.hs+1−2
@@ -1,10 +1,9 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21{-# LANGUAGE ScopedTypeVariables #-}
3−
42{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
53
64module Main (main) where
75
6+import Prelude ()
87import Prelude.Compat
98
109import Criterion.Main
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 #-}
64
75module Main (main) where
86
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+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Main (main) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Criterion.Main
benchmarks/ReadFile.hs+1−1
@@ -1,9 +1,9 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE NoImplicitPrelude #-}
32{-# LANGUAGE OverloadedStrings #-}
43
54module Main (main) where
65
6+import Prelude ()
77import Prelude.Compat
88
99import Control.DeepSeq
benchmarks/Typed.hs+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Main (main) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Criterion.Main
benchmarks/Typed/Common.hs+1−2
@@ -1,9 +1,8 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31{-# OPTIONS_GHC -fno-warn-unused-imports #-}
42
53module Typed.Common (load) where
64
5+import Prelude ()
76import Prelude.Compat
87
98import Data.ByteString.Lazy as L
benchmarks/Typed/Generic.hs+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Typed.Generic (benchmarks, decodeBenchmarks) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Data.Aeson hiding (Result)
benchmarks/Typed/Manual.hs+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Typed.Manual (benchmarks, decodeBenchmarks) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Data.Aeson hiding (Result)
benchmarks/Typed/TH.hs+1−2
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Typed.TH (benchmarks, decodeBenchmarks) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Data.Aeson hiding (Result)
benchmarks/aeson-benchmarks.cabal+26−52
@@ -28,42 +28,39 @@ library
2828 hs-source-dirs: .. ../ffi ../pure ../attoparsec-iso8601
2929 c-sources: ../cbits/unescape_string.c
3030 build-depends:
31− attoparsec,
32− base,
33− base-compat,
31+ attoparsec >= 0.13.0.1,
32+ base == 4.*,
33+ base-compat >= 0.9.1 && <0.10,
34+ time-locale-compat >=0.1.1 && <0.2,
3435 containers,
3536 deepseq,
36− dlist,
37− fail,
38− ghc-prim,
39− hashable,
37+ dlist >= 0.2,
38+ fail == 4.9.*,
39+ ghc-prim >= 0.2,
40+ hashable >= 1.1.2.0,
4041 mtl,
41− primitive,
42− scientific,
42+ scientific >= 0.3.4.7 && < 0.4,
4343 syb,
44− tagged,
45− template-haskell,
46− text,
47− th-abstraction,
48− time-compat,
44+ tagged >=0.8.3 && <0.9,
45+ template-haskell >= 2.4,
46+ text >= 1.1.1.0,
47+ th-abstraction >= 0.2.2 && < 0.3,
4948 time,
5049 transformers,
51− unordered-containers,
52− uuid-types,
53− vector
50+ unordered-containers >= 0.2.3.0,
51+ uuid-types >= 1.0.3 && <1.1,
52+ vector >= 0.7.1
5453
55− if !impl(ghc >= 8.6)
56− build-depends: contravariant
54+ if !impl(ghc >= 7.10)
55+ -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8
56+ build-depends: nats >= 1 && < 1.2
57+
58+ if impl(ghc >=7.8)
59+ cpp-options: -DHAS_COERCIBLE
5760
5861 if !impl(ghc >= 8.0)
5962 -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9
60− build-depends: semigroups,
61− transformers-compat
62−
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
63+ build-depends: semigroups >= 0.18.2 && < 0.19
6764
6865 include-dirs: ../include
6966
@@ -72,6 +69,7 @@ library
7269
7370 exposed-modules:
7471 Data.Aeson
72+ Data.Aeson.Compat
7573 Data.Aeson.Encoding
7674 Data.Aeson.Encoding.Builder
7775 Data.Aeson.Encoding.Internal
@@ -156,6 +154,7 @@ executable aeson-benchmark-compare
156154 other-modules:
157155 Compare.BufferBuilder
158156 Compare.JsonBench
157+ Compare.JsonBuilder
159158 Twitter
160159 Twitter.Manual
161160 Typed.Common
@@ -168,17 +167,9 @@ executable aeson-benchmark-compare
168167 criterion >= 1.0,
169168 deepseq,
170169 ghc-prim,
170+ json-builder,
171171 text
172172
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−
182173executable aeson-benchmark-micro
183174 default-language: Haskell2010
184175 main-is: Micro.hs
@@ -224,8 +215,6 @@ executable aeson-benchmark-typed
224215 bytestring-builder >= 0.10.4 && < 1
225216 else
226217 build-depends: bytestring >= 0.10.4
227− if impl(ghc < 8.0)
228− build-depends: semigroups
229218
230219executable aeson-benchmark-compare-with-json
231220 default-language: Haskell2010
@@ -328,18 +317,3 @@ executable aeson-benchmark-foldable
328317 text,
329318 unordered-containers,
330319 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.project+1−4
@@ -1,5 +1,2 @@
11with-compiler: ghc
2−packages: .
3−packages: attoparsec-iso8601
4−-- packages: benchmarks
5−tests: true
2+packages: ., attoparsec-iso8601
changelog.md−134
@@ -1,139 +1,5 @@
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).
22
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−
1373### 1.2.3.0
1384
1395* Added `withEmbeddedJSON` to help parse JSON embedded inside a JSON string, thanks to Jesse Kempf.
examples/Generic.hs+1−1
@@ -6,11 +6,11 @@
66-- automatically derive the Generic class for us.
77
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 #-}
43
54module Main (main) where
65
6+import Prelude ()
77import Prelude.Compat
88
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 #-}
76
87module Main (main) where
98
9+import Prelude ()
1010import Prelude.Compat
1111
1212import Data.Aeson (decode, encode)
examples/Twitter.hs+2−1
@@ -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,6 +27,7 @@ import Data.Data (Typeable, Data)
2727import Data.Int (Int64)
2828import Data.Text (Text)
2929import GHC.Generics (Generic)
30+import Prelude hiding (id)
3031
3132{-# ANN module "Hlint: ignore Use camelCase" #-}
3233{-# ANN module "Hlint: ignore Use newtype instead of data" #-}
examples/Twitter/Generic.hs+1−2
@@ -1,7 +1,5 @@
11-- Use GHC generics to automatically generate good instances.
22
3−{-# LANGUAGE NoImplicitPrelude #-}
4−
53{-# OPTIONS_GHC -fno-warn-orphans #-}
64
75module Twitter.Generic
@@ -12,6 +10,7 @@ module Twitter.Generic
1210 , Result(..)
1311 ) where
1412
13+import Prelude ()
1514import Prelude.Compat ()
1615
1716import Twitter
examples/Twitter/Manual.hs+4−3
@@ -1,8 +1,7 @@
11-- Manually write instances.
2−{-# LANGUAGE NoImplicitPrelude #-}
2+
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE RecordWildCards #-}
5−
65{-# OPTIONS_GHC -fno-warn-orphans #-}
76
87module Twitter.Manual
@@ -13,10 +12,12 @@ module Twitter.Manual
1312 , Result(..)
1413 ) where
1514
15+import Prelude ()
1616import Prelude.Compat
1717
1818import Control.Applicative
19−import Data.Semigroup ((<>))
19+import Data.Monoid ((<>))
20+import Prelude hiding (id)
2021import Twitter
2122
2223import Data.Aeson hiding (Result)
examples/Twitter/TH.hs+1−2
@@ -1,8 +1,6 @@
11-- Use Template Haskell to generate good instances.
22
3−{-# LANGUAGE NoImplicitPrelude #-}
43{-# LANGUAGE TemplateHaskell #-}
5−
64{-# OPTIONS_GHC -fno-warn-orphans #-}
75
86module Twitter.TH
@@ -13,6 +11,7 @@ module Twitter.TH
1311 , Result(..)
1412 ) where
1513
14+import Prelude ()
1615
1716import Twitter
1817import Twitter.Options
ffi/Data/Aeson/Parser/UnescapeFFI.hs+1−1
@@ -10,7 +10,7 @@ module Data.Aeson.Parser.UnescapeFFI
1010import Control.Exception (evaluate, throw, try)
1111import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
1212import Data.ByteString as B
13−import Data.ByteString.Internal as B
13+import Data.ByteString.Internal as B hiding (c2w)
1414import Data.Text.Encoding.Error (UnicodeException (..))
1515import Data.Text.Internal (Text (..))
1616import Data.Text.Internal.Private (runText)
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+3−2
@@ -1,4 +1,4 @@
1−resolver: nightly-2019-09-21
1+resolver: nightly-2017-10-18
22# We use aeson in the snapshot to
33# - avoid recompilation of criterion
44# - compare against it
@@ -9,4 +9,5 @@ resolver: nightly-2019-09-21
99work-dir: .stack-work-bench
1010packages:
1111- benchmarks
12−extra-deps: []
12+extra-deps:
13+- aeson-1.2.2.0
stack-ffi-unescape.yaml+1−3
@@ -1,9 +1,7 @@
1−resolver: nightly-2019-09-21
1+resolver: nightly-2017-10-18
22packages:
33- '.'
44flags:
55 aeson:
66 fast: true
77 cffi: true
8−extra-deps:
9−- Diff-0.4.0
stack-lts12.yamldeleted−15
@@ -1,15 +0,0 @@
1−resolver: lts-12.26
2−packages:
3−- '.'
4−- attoparsec-iso8601
5−flags:
6− aeson:
7− fast: true
8− cffi: true
9−extra-deps:
10−- base-orphans-0.8.1
11−- hashable-time-0.2.0.1
12−- QuickCheck-2.13.1
13−- quickcheck-instances-0.3.21
14−- splitmix-0.0.2
15−- time-compat-1.9.2.2
stack-lts6.yamlnew file+24
@@ -0,0 +1,24 @@
1+resolver: lts-6.35
2+packages:
3+- '.'
4+- attoparsec-iso8601
5+extra-deps:
6+- integer-logarithms-1
7+- semigroups-0.18.2
8+- tagged-0.8.5
9+- transformers-compat-0.5.1.4
10+- QuickCheck-2.10.0.1
11+- base-compat-0.9.3
12+- hashable-1.2.6.1
13+- integer-logarithms-1
14+- quickcheck-instances-0.3.16
15+- test-framework-quickcheck2-0.3.0.4
16+- th-abstraction-0.2.2.0
17+flags:
18+flags:
19+ aeson:
20+ fast: true
21+ attoparsec-iso8601:
22+ fast: true
23+ semigroups:
24+ bytestring-builder: false
stack-lts7.yamlnew file+17
@@ -0,0 +1,17 @@
1+resolver: lts-7.24
2+packages:
3+- '.'
4+- attoparsec-iso8601
5+extra-deps:
6+- QuickCheck-2.10.0.1
7+- base-compat-0.9.3
8+- hashable-1.2.6.1
9+- integer-logarithms-1
10+- quickcheck-instances-0.3.16
11+- test-framework-quickcheck2-0.3.0.4
12+- th-abstraction-0.2.2.0
13+flags:
14+ aeson:
15+ fast: true
16+ attoparsec-iso8601:
17+ fast: true
stack-lts8.yamlnew file+15
@@ -0,0 +1,15 @@
1+resolver: lts-8.24
2+packages:
3+- '.'
4+- attoparsec-iso8601
5+extra-deps:
6+- QuickCheck-2.10.0.1
7+- base-compat-0.9.3
8+- quickcheck-instances-0.3.16
9+- th-abstraction-0.2.2.0
10+- test-framework-quickcheck2-0.3.0.4
11+flags:
12+ aeson:
13+ fast: true
14+ attoparsec-iso8601:
15+ fast: true
stack-lts9.yamlnew file+12
@@ -0,0 +1,12 @@
1+resolver: lts-9.9
2+packages:
3+- '.'
4+- attoparsec-iso8601
5+extra-deps:
6+- quickcheck-instances-0.3.16
7+- QuickCheck-2.10.0.1
8+flags:
9+ aeson:
10+ fast: true
11+ attoparsec-iso8601:
12+ fast: true
stack-nightly.yaml+1−3
@@ -1,4 +1,4 @@
1−resolver: nightly-2019-10-14
1+resolver: nightly-2017-10-18
22packages:
33- '.'
44- attoparsec-iso8601
@@ -7,5 +7,3 @@ flags:
77 fast: true
88 attoparsec-iso8601:
99 fast: true
10−extra-deps:
11−- generic-deriving-1.12.4
tests/DataFamilies/Encoders.hs+1−1
@@ -1,10 +1,10 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoImplicitPrelude #-}
43{-# LANGUAGE TemplateHaskell #-}
54
65module DataFamilies.Encoders (module DataFamilies.Encoders) where
76
7+import Prelude ()
88import Prelude.Compat
99
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 #-}
86
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 #-}
32
43module DataFamilies.Properties (tests) where
54
5+import Prelude ()
66import Prelude.Compat
77
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+1−1
@@ -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
1211module DataFamilies.Types (module DataFamilies.Types) where
1312
13+import Prelude ()
1414import Prelude.Compat
1515
1616import Generics.Deriving.TH (deriveAll0)
tests/Encoders.hs+7−49
@@ -1,12 +1,11 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoImplicitPrelude #-}
43{-# LANGUAGE TemplateHaskell #-}
54
65module Encoders (module Encoders) where
76
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
@@ -243,31 +236,6 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding
243236gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields
244237
245238
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−
271239--------------------------------------------------------------------------------
272240-- Option fields
273241--------------------------------------------------------------------------------
@@ -446,13 +414,3 @@ gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors
446414
447415gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
448416gOneConstructorParseJSONTagged = 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+54−207
@@ -1,4 +1,3 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
21{-# LANGUAGE OverloadedStrings #-}
32{-# LANGUAGE ScopedTypeVariables #-}
43
@@ -7,218 +6,66 @@ module ErrorMessages
76 tests
87 ) where
98
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 ()
2115import Numeric.Natural (Natural)
22−import Test.Tasty (TestTree, TestName)
23−import Test.Tasty.Golden.Advanced (goldenTest)
16+import Test.Framework (Test)
17+import Test.Framework.Providers.HUnit (testCase)
18+import Test.HUnit (Assertion, assertFailure, assertEqual)
2419import qualified Data.ByteString.Lazy.Char8 as L
2520import qualified Data.HashMap.Strict as HM
2621
27−import Encoders
28−import Types
29−
30−tests :: [TestTree]
22+tests :: [Test]
3123tests =
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
24+ [
25+ testCase "Int" int
26+ , testCase "Integer" integer
27+ , testCase "Natural" natural
28+ , testCase "String" string
29+ , testCase "HashMap" hashMap
30+ ]
31+
32+int :: Assertion
33+int = do
34+ let t = test (Proxy :: Proxy Int)
35+ t "\"\"" $ expected "Int" "String"
36+ t "[]" $ expected "Int" "Array"
37+ t "{}" $ expected "Int" "Object"
38+ t "null" $ expected "Int" "Null"
39+
40+integer :: Assertion
41+integer = do
42+ let t = test (Proxy :: Proxy Integer)
43+ t "44.44" $ expected "Integer" "floating number 44.44"
44+
45+natural :: Assertion
46+natural = do
47+ let t = test (Proxy :: Proxy Natural)
48+ t "44.44" $ expected "Natural" "floating number 44.44"
49+ t "-50" $ expected "Natural" "negative number -50"
50+
51+string :: Assertion
52+string = do
53+ let t = test (Proxy :: Proxy String)
54+ t "1" $ expected "String" "Number"
55+ t "[]" $ expected "String" "Array"
56+ t "{}" $ expected "String" "Object"
57+ t "null" $ expected "String" "Null"
58+
59+hashMap :: Assertion
60+hashMap = do
61+ let t = test (Proxy :: Proxy (HM.HashMap String Int))
62+ t "\"\"" $ expected "HashMap k v" "String"
63+ t "[]" $ expected "HashMap k v" "Array"
64+
65+expected :: String -> String -> String
66+expected ex enc = "Error in $: expected " ++ ex ++ ", encountered " ++ enc
67+
68+test :: forall a proxy . (FromJSON a, Show a) => proxy a -> L.ByteString -> String -> Assertion
69+test _ v msg = case eitherDecode v of
70+ Left e -> assertEqual "Invalid error message" msg e
71+ 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
86
7+import Prelude ()
98import Prelude.Compat
109
1110approxEq :: (Fractional a, Ord a) => a -> a -> Bool
tests/Instances.hs+5−3
@@ -1,13 +1,13 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE NoImplicitPrelude #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE RecordWildCards #-}
6−
76{-# OPTIONS_GHC -fno-warn-orphans #-}
87
98module Instances () where
109
10+import Prelude ()
1111import Prelude.Compat
1212
1313import Control.Applicative (empty)
@@ -24,12 +24,14 @@ import qualified Data.HashMap.Strict as HM
2424
2525import Data.Orphans ()
2626import Test.QuickCheck.Instances ()
27+#if MIN_VERSION_base(4,7,0)
2728import Data.Hashable.Time ()
29+#endif
2830
2931-- "System" types.
3032
3133instance Arbitrary DotNetTime where
32− arbitrary = DotNetTime `fmap` arbitrary
34+ arbitrary = DotNetTime `liftM` arbitrary
3335 shrink = map DotNetTime . shrink . fromDotNetTime
3436
3537-- | Compare timezone part only on 'timeZoneMinutes'
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
64
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/Options.hs+1−13
@@ -1,7 +1,6 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Options (module Options) where
42
3+import Prelude ()
54import Prelude.Compat
65
76import Data.Aeson.Types
@@ -55,14 +54,3 @@ optsOptionField = optsDefault
5554 { fieldLabelModifier = const "field"
5655 , omitNothingFields = True
5756 }
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+532−14
@@ -1,28 +1,331 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-} -- For arbitrary Compose
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
26
37module Properties (module Properties) where
48
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 qualified Data.Aeson.Internal as I
17+import Data.Aeson.Parser (value)
18+import Data.Aeson.Types
19+import Data.DList (DList)
20+import Data.Functor.Compose (Compose (..))
21+import Data.HashMap.Strict (HashMap)
22+import Data.Hashable (Hashable)
23+import Data.Int (Int8)
24+import Data.List.NonEmpty (NonEmpty)
25+import Data.Map (Map)
26+import Data.Proxy (Proxy)
27+import Data.Ratio (Ratio)
28+import Data.Semigroup (Option(..))
29+import Data.Sequence (Seq)
30+import Data.Tagged (Tagged)
31+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
32+import Data.Version (Version)
33+import Encoders
734import 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
35+import Numeric.Natural (Natural)
36+import Test.Framework (Test, testGroup)
37+import Test.Framework.Providers.QuickCheck2 (testProperty)
38+import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)
39+import Types
40+import qualified Data.Attoparsec.Lazy as L
41+import qualified Data.ByteString.Lazy.Char8 as L
42+import qualified Data.HashMap.Strict as H
43+import qualified Data.Map as Map
44+import qualified Data.Text as T
45+import qualified Data.Text.Lazy as LT
46+import qualified Data.UUID.Types as UUID
47+import qualified Data.Vector as V
1648
49+encodeDouble :: Double -> Double -> Property
50+encodeDouble num denom
51+ | isInfinite d || isNaN d = encode d === "null"
52+ | otherwise = (read . L.unpack . encode) d === d
53+ where d = num / denom
1754
18−tests :: TestTree
55+encodeInteger :: Integer -> Property
56+encodeInteger i = encode i === L.pack (show i)
57+
58+toParseJSON :: (Eq a, Show a) =>
59+ (Value -> Parser a) -> (a -> Value) -> a -> Property
60+toParseJSON parsejson tojson x =
61+ case iparse parsejson . tojson $ x of
62+ IError path msg -> failure "parse" (formatError path msg) x
63+ ISuccess x' -> x === x'
64+
65+toParseJSON1
66+ :: (Eq (f Int), Show (f Int))
67+ => (forall a. LiftParseJSON f a)
68+ -> (forall a. LiftToJSON f a)
69+ -> f Int
70+ -> Property
71+toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson
72+ where
73+ parsejson = parsejson1 parseJSON (listParser parseJSON)
74+ tojson = tojson1 toJSON (listValue toJSON)
75+
76+roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>
77+ (a -> a -> Property) -> a -> a -> Property
78+roundTripEnc eq _ i =
79+ case fmap ifromJSON . L.parse value . encode $ i of
80+ L.Done _ (ISuccess v) -> v `eq` i
81+ L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i
82+ L.Fail _ _ err -> failure "parse" err i
83+
84+roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>
85+ (a -> a -> Property) -> a -> a -> Property
86+roundTripNoEnc eq _ i =
87+ case ifromJSON . toJSON $ i of
88+ (ISuccess v) -> v `eq` i
89+ (IError path err) -> failure "fromJSON" (formatError path err) i
90+
91+roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property
92+roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y
93+
94+-- We test keys by encoding HashMap and Map with it
95+roundTripKey
96+ :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)
97+ => a -> HashMap a Int -> Map a Int -> Property
98+roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m
99+
100+infix 4 ==~
101+(==~) :: (ApproxEq a, Show a) => a -> a -> Property
102+x ==~ y =
103+ counterexample (show x ++ " /= " ++ show y) (x =~ y)
104+
105+toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property
106+toFromJSON x = case ifromJSON (toJSON x) of
107+ IError path err -> failure "fromJSON" (formatError path err) x
108+ ISuccess x' -> x === x'
109+
110+modifyFailureProp :: String -> String -> Bool
111+modifyFailureProp orig added =
112+ result == Error (added ++ orig)
113+ where
114+ parser = const $ modifyFailure (added ++) $ fail orig
115+ result :: Result ()
116+ result = parse parser ()
117+
118+parserThrowErrorProp :: String -> Property
119+parserThrowErrorProp msg =
120+ result === Error msg
121+ where
122+ parser = const $ parserThrowError [] msg
123+ result :: Result ()
124+ result = parse parser ()
125+
126+-- | Tests (also) that we catch the JSONPath and it has elements in the right order.
127+parserCatchErrorProp :: [String] -> String -> Property
128+parserCatchErrorProp path msg =
129+ result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)
130+ where
131+ parser = parserCatchError outer (curry pure)
132+
133+ outer = inner I.<?> I.Key "outer"
134+ inner = parserThrowError jsonPath msg I.<?> I.Key "inner"
135+
136+ result :: Result (I.JSONPath, String)
137+ result = parse (const parser) ()
138+
139+ jsonPath = map (I.Key . T.pack) path
140+
141+-- | Perform a structural comparison of the results of two encoding
142+-- methods. Compares decoded values to account for HashMap-driven
143+-- variation in JSON object key ordering.
144+sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
145+sameAs toVal toEnc v =
146+ counterexample (show s) $
147+ eitherDecode s === Right (toVal v)
148+ where
149+ s = encodingToLazyByteString (toEnc v)
150+
151+sameAs1
152+ :: (forall a. LiftToJSON f a)
153+ -> (forall a. LiftToEncoding f a)
154+ -> f Int
155+ -> Property
156+sameAs1 toVal1 toEnc1 v = lhs === rhs
157+ where
158+ rhs = Right $ toVal1 toJSON (listValue toJSON) v
159+ lhs = eitherDecode . encodingToLazyByteString $
160+ toEnc1 toEncoding (listEncoding toEncoding) v
161+
162+sameAs1Agree
163+ :: ToJSON a
164+ => (f a -> Encoding)
165+ -> (forall b. LiftToEncoding f b)
166+ -> f a
167+ -> Property
168+sameAs1Agree toEnc toEnc1 v = rhs === lhs
169+ where
170+ rhs = encodingToLazyByteString $ toEnc v
171+ lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v
172+
173+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
174+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
175+
176+--------------------------------------------------------------------------------
177+-- Value properties
178+--------------------------------------------------------------------------------
179+
180+-- | Add the formatted @Value@ to the printed counterexample when the property
181+-- fails.
182+checkValue :: Testable a => (Value -> a) -> Value -> Property
183+checkValue prop v = counterexample (L.unpack (encode v)) (prop v)
184+
185+isString :: Value -> Bool
186+isString (String _) = True
187+isString _ = False
188+
189+is2ElemArray :: Value -> Bool
190+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
191+is2ElemArray _ = False
192+
193+isTaggedObjectValue :: Value -> Bool
194+isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
195+ "contents" `H.member` obj
196+isTaggedObjectValue _ = False
197+
198+isNullaryTaggedObject :: Value -> Bool
199+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj
200+
201+isTaggedObject :: Value -> Property
202+isTaggedObject = checkValue isTaggedObject'
203+
204+isTaggedObject' :: Value -> Bool
205+isTaggedObject' (Object obj) = "tag" `H.member` obj
206+isTaggedObject' _ = False
207+
208+isObjectWithSingleField :: Value -> Bool
209+isObjectWithSingleField (Object obj) = H.size obj == 1
210+isObjectWithSingleField _ = False
211+
212+-- | is untaggedValue of EitherTextInt
213+isUntaggedValueETI :: Value -> Bool
214+isUntaggedValueETI (String s)
215+ | s == "nonenullary" = True
216+isUntaggedValueETI (Bool _) = True
217+isUntaggedValueETI (Number _) = True
218+isUntaggedValueETI (Array a) = length a == 2
219+isUntaggedValueETI _ = False
220+
221+isEmptyArray :: Value -> Property
222+isEmptyArray = checkValue isEmptyArray'
223+
224+isEmptyArray' :: Value -> Bool
225+isEmptyArray' = (Array mempty ==)
226+
227+
228+--------------------------------------------------------------------------------
229+
230+
231+tests :: Test
19232tests = testGroup "properties" [
20233 testGroup "encode" [
21234 testProperty "encodeDouble" encodeDouble
22235 , testProperty "encodeInteger" encodeInteger
23236 ]
24− , roundTripTests
25− , keysTests
237+ , testGroup "roundTrip" [
238+ testProperty "Bool" $ roundTripEq True
239+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)
240+ , testProperty "Int" $ roundTripEq (1 :: Int)
241+ , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)
242+ , testProperty "Integer" $ roundTripEq (1 :: Integer)
243+ , testProperty "String" $ roundTripEq ("" :: String)
244+ , testProperty "Text" $ roundTripEq T.empty
245+ , testProperty "Lazy Text" $ roundTripEq LT.empty
246+ , testProperty "Foo" $ roundTripEq (undefined :: Foo)
247+ , testProperty "Day" $ roundTripEq (undefined :: Day)
248+ , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)
249+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
250+ , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)
251+ , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)
252+ , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)
253+ , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)
254+ , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)
255+ , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)
256+ , testProperty "Version" $ roundTripEq (undefined :: Version)
257+ , testProperty "Natural" $ roundTripEq (undefined :: Natural)
258+ , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)
259+ , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)
260+ , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)
261+ , testProperty "DList" $ roundTripEq (undefined :: DList Int)
262+ , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)
263+ , testProperty "Rational" $ roundTripEq (undefined :: Rational)
264+ , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)
265+ , testProperty "UUID" $ roundTripEq UUID.nil
266+ , testGroup "functors"
267+ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)
268+
269+ , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)
270+ , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String)
271+ , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])
272+
273+ , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int))
274+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))
275+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))
276+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))
277+
278+ , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))
279+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))
280+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))
281+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))
282+
283+ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))
284+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))
285+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))
286+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))
287+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))
288+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))
289+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))
290+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))
291+
292+ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))
293+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))
294+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))
295+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))
296+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))
297+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))
298+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))
299+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] [] Char))
300+ ]
301+ , testGroup "ghcGenerics" [
302+ testProperty "OneConstructor" $ roundTripEq OneConstructor
303+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
304+ , testProperty "Product6" $ roundTripEq (undefined :: P6)
305+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)
306+ ]
307+ ]
308+ , testGroup "roundTrip Key"
309+ [ testProperty "Bool" $ roundTripKey True
310+ , testProperty "Text" $ roundTripKey (undefined :: T.Text)
311+ , testProperty "String" $ roundTripKey (undefined :: String)
312+ , testProperty "Int" $ roundTripKey (undefined :: Int)
313+ , testProperty "[Text]" $ roundTripKey (undefined :: LogScaled [T.Text])
314+ , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))
315+ , testProperty "Integer" $ roundTripKey (undefined :: Integer)
316+ , testProperty "Natural" $ roundTripKey (undefined :: Natural)
317+ , testProperty "Float" $ roundTripKey (undefined :: Float)
318+ , testProperty "Double" $ roundTripKey (undefined :: Double)
319+#if MIN_VERSION_base(4,7,0)
320+ , testProperty "Day" $ roundTripKey (undefined :: Day)
321+ , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)
322+ , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)
323+ , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
324+#endif
325+ , testProperty "Version" $ roundTripKey (undefined :: Version)
326+ , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)
327+ , testProperty "UUID" $ roundTripKey UUID.nil
328+ ]
26329 , testGroup "toFromJSON" [
27330 testProperty "Integer" (toFromJSON :: Integer -> Property)
28331 , testProperty "Double" (toFromJSON :: Double -> Property)
@@ -35,6 +338,221 @@ tests = testGroup "properties" [
35338 , testProperty "parserThrowError" parserThrowErrorProp
36339 , testProperty "parserCatchError" parserCatchErrorProp
37340 ]
38− , genericTests
39− , templateHaskellTests
341+ , testGroup "generic" [
342+ testGroup "toJSON" [
343+ testGroup "Nullary" [
344+ testProperty "string" (isString . gNullaryToJSONString)
345+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
346+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
347+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
348+ , testGroup "roundTrip" [
349+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
350+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
351+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
352+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
353+ ]
354+ ]
355+ , testGroup "EitherTextInt" [
356+ testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)
357+ , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)
358+ ]
359+ , testGroup "SomeType" [
360+ testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
361+ , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
362+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
363+ , testGroup "roundTrip" [
364+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
365+ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
366+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
367+
368+#if __GLASGOW_HASKELL__ >= 706
369+ , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)
370+ , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)
371+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)
372+#endif
373+ ]
374+ ]
375+ , testGroup "OneConstructor" [
376+ testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)
377+ , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)
378+ , testGroup "roundTrip" [
379+ testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)
380+ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)
381+ ]
382+ ]
383+ , testGroup "OptionField" [
384+ testProperty "like Maybe" $
385+ \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
386+ , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)
387+ ]
388+ ]
389+ , testGroup "toEncoding" [
390+ testProperty "NullaryString" $
391+ gNullaryToJSONString `sameAs` gNullaryToEncodingString
392+ , testProperty "Nullary2ElemArray" $
393+ gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray
394+ , testProperty "NullaryTaggedObject" $
395+ gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject
396+ , testProperty "NullaryObjectWithSingleField" $
397+ gNullaryToJSONObjectWithSingleField `sameAs`
398+ gNullaryToEncodingObjectWithSingleField
399+ -- , testProperty "ApproxUnwrap" $
400+ -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
401+ , testProperty "ApproxDefault" $
402+ gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
403+
404+ , testProperty "EitherTextInt UntaggedValue" $
405+ gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue
406+
407+ , testProperty "SomeType2ElemArray" $
408+ gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray
409+#if __GLASGOW_HASKELL__ >= 706
410+ , testProperty "SomeType2ElemArray unary" $
411+ gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray
412+ , testProperty "SomeType2ElemArray unary agree" $
413+ gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray
414+#endif
415+
416+ , testProperty "SomeTypeTaggedObject" $
417+ gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject
418+#if __GLASGOW_HASKELL__ >= 706
419+ , testProperty "SomeTypeTaggedObject unary" $
420+ gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject
421+ , testProperty "SomeTypeTaggedObject unary agree" $
422+ gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject
423+#endif
424+
425+ , testProperty "SomeTypeObjectWithSingleField" $
426+ gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField
427+#if __GLASGOW_HASKELL__ >= 706
428+ , testProperty "SomeTypeObjectWithSingleField unary" $
429+ gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField
430+ , testProperty "SomeTypeObjectWithSingleField unary agree" $
431+ gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField
432+#endif
433+
434+ , testProperty "SomeTypeOmitNothingFields" $
435+ gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
436+
437+ , testProperty "OneConstructorDefault" $
438+ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
439+ , testProperty "OneConstructorTagged" $
440+ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
441+
442+ , testProperty "OptionField" $
443+ gOptionFieldToJSON `sameAs` gOptionFieldToEncoding
444+ ]
445+ ]
446+ , testGroup "template-haskell" [
447+ testGroup "toJSON" [
448+ testGroup "Nullary" [
449+ testProperty "string" (isString . thNullaryToJSONString)
450+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
451+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
452+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
453+
454+ , testGroup "roundTrip" [
455+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
456+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
457+ , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)
458+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
459+ ]
460+ ]
461+ , testGroup "EitherTextInt" [
462+ testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)
463+ , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)
464+ ]
465+ , testGroup "SomeType" [
466+ testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)
467+ , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)
468+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)
469+ , testGroup "roundTrip" [
470+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
471+ , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
472+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
473+
474+ , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)
475+ , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)
476+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
477+
478+ ]
479+ ]
480+ , testGroup "Approx" [
481+ testProperty "string" (isString . thApproxToJSONUnwrap)
482+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
483+ , testGroup "roundTrip" [
484+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
485+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
486+ ]
487+ ]
488+ , testGroup "GADT" [
489+ testProperty "string" (isString . thGADTToJSONUnwrap)
490+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
491+ , testGroup "roundTrip" [
492+ testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
493+ , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
494+ ]
495+ ]
496+ , testGroup "OneConstructor" [
497+ testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
498+ , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)
499+ , testGroup "roundTrip" [
500+ testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
501+ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)
502+ ]
503+ ]
504+ , testGroup "OptionField" [
505+ testProperty "like Maybe" $
506+ \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
507+ , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)
508+ ]
509+ ]
510+ , testGroup "toEncoding" [
511+ testProperty "NullaryString" $
512+ thNullaryToJSONString `sameAs` thNullaryToEncodingString
513+ , testProperty "Nullary2ElemArray" $
514+ thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray
515+ , testProperty "NullaryTaggedObject" $
516+ thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject
517+ , testProperty "NullaryObjectWithSingleField" $
518+ thNullaryToJSONObjectWithSingleField `sameAs`
519+ thNullaryToEncodingObjectWithSingleField
520+ , testProperty "ApproxUnwrap" $
521+ thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap
522+ , testProperty "ApproxDefault" $
523+ thApproxToJSONDefault `sameAs` thApproxToEncodingDefault
524+
525+ , testProperty "EitherTextInt UntaggedValue" $
526+ thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue
527+
528+ , testProperty "SomeType2ElemArray" $
529+ thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray
530+ , testProperty "SomeType2ElemArray unary" $
531+ thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray
532+ , testProperty "SomeType2ElemArray unary agree" $
533+ thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray
534+
535+ , testProperty "SomeTypeTaggedObject" $
536+ thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject
537+ , testProperty "SomeTypeTaggedObject unary" $
538+ thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject
539+ , testProperty "SomeTypeTaggedObject unary agree" $
540+ thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject
541+
542+ , testProperty "SomeTypeObjectWithSingleField" $
543+ thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField
544+ , testProperty "SomeTypeObjectWithSingleField unary" $
545+ thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField
546+ , testProperty "SomeTypeObjectWithSingleField unary agree" $
547+ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
548+
549+ , testProperty "OneConstructorDefault" $
550+ thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
551+ , testProperty "OneConstructorTagged" $
552+ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
553+
554+ , testProperty "OptionField" $
555+ thOptionFieldToJSON `sameAs` thOptionFieldToEncoding
556+ ]
557+ ]
40558 ]
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+30−53
@@ -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
78
89------------------------------------------------------------------------------
910-- These tests assert that the JSON serialization doesn't change by accident.
@@ -14,6 +15,7 @@ module SerializationFormatSpec
1415 tests
1516 ) where
1617
18+import Prelude ()
1719import Prelude.Compat
1820
1921import Control.Applicative (Const(..))
@@ -30,14 +32,12 @@ import Data.Proxy (Proxy(..))
3032import Data.Scientific (Scientific)
3133import Data.Tagged (Tagged(..))
3234import 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 (..))
3635import Data.Word (Word8)
3736import GHC.Generics (Generic)
3837import Instances ()
39−import Test.Tasty (TestTree, testGroup)
40−import Test.Tasty.HUnit (assertFailure, assertEqual, testCase)
38+import Test.Framework (Test, testGroup)
39+import Test.Framework.Providers.HUnit (testCase)
40+import Test.HUnit (assertFailure, assertEqual)
4141import Types (Approx(..), Compose3, Compose3', I)
4242import qualified Data.ByteString.Lazy.Char8 as L
4343import qualified Data.DList as DList
@@ -54,7 +54,7 @@ import qualified Data.Tree as Tree
5454import qualified Data.UUID.Types as UUID
5555import qualified Data.Vector as Vector
5656
57−tests :: [TestTree]
57+tests :: [Test]
5858tests =
5959 [
6060 testGroup "To JSON representation" $ fmap assertJsonEncodingExample jsonEncodingExamples
@@ -69,14 +69,13 @@ jsonExamples =
6969 example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)
7070 , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)
7171 , 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
7572 , example "Just" "1" (Just 1 :: Maybe Int)
7673 , example "Proxy Int" "null" (Proxy :: Proxy Int)
7774 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)
75+#if __GLASGOW_HASKELL__ >= 708
7876 -- Test Tagged instance is polykinded
7977 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)
78+#endif
8079 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)
8180 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))
8281 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)
@@ -84,22 +83,22 @@ jsonExamples =
8483 , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)
8584 , example "()" "[]" ()
8685
87− , ndExample "HashMap Int Int"
86+ , Example "HashMap Int Int"
8887 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
8988 (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)
90− , ndExample "Map Int Int"
89+ , Example "Map Int Int"
9190 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
9291 (M.fromList [(0,1),(2,3)] :: M.Map Int Int)
93− , ndExample "Map (Tagged Int Int) Int"
92+ , Example "Map (Tagged Int Int) Int"
9493 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]
9594 (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)
9695 , example "Map [Int] Int"
9796 "[[[0],1],[[2],3]]"
9897 (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)
99− , ndExample "Map [Char] Int"
98+ , Example "Map [Char] Int"
10099 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]
101100 (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)
102− , ndExample "Map [I Char] Int"
101+ , Example "Map [I Char] Int"
103102 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]
104103 (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)
105104
@@ -195,27 +194,16 @@ jsonExamples =
195194 , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)
196195 , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)
197196 , 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
211197 ]
212198
213199jsonEncodingExamples :: [Example]
214200jsonEncodingExamples =
215201 [
202+ -- Maybe serialising is lossy
203+ -- https://github.com/bos/aeson/issues/376
204+ example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))
216205 -- 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)
206+ , example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)
219207 ]
220208
221209jsonDecodingExamples :: [Example]
@@ -237,27 +225,16 @@ jsonDecodingExamples = [
237225 ]
238226
239227data 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
228+ Example
229+ :: (Eq a, Show a, ToJSON a, FromJSON a)
230+ => String -> [L.ByteString] -> a -> Example -- empty bytestring will fail, any p [] == False
231+ MaybeExample
232+ :: (Eq a, Show a, FromJSON a)
233+ => String -> L.ByteString -> Maybe a -> Example
251234
252235example :: (Eq a, Show a, ToJSON a, FromJSON a)
253236 => 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−
237+example n bs x = Example n [bs] x
261238
262239data MyEither a b = MyLeft a | MyRight b
263240 deriving (Generic, Show, Eq)
@@ -269,17 +246,17 @@ instance (ToJSON a, ToJSON b) => ToJSON (MyEither a b) where
269246instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where
270247 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }
271248
272−assertJsonExample :: Example -> TestTree
273−assertJsonExample (Example name bss val val') = testCase name $ do
249+assertJsonExample :: Example -> Test
250+assertJsonExample (Example name bss val) = testCase name $ do
274251 assertSomeEqual "encode" bss (encode val)
275252 assertSomeEqual "encode/via value" bss (encode $ toJSON val)
276253 for_ bss $ \bs ->
277− assertEqual "decode" (Just val') (decode bs)
254+ assertEqual "decode" (Just val) (decode bs)
278255assertJsonExample (MaybeExample name bs mval) = testCase name $
279256 assertEqual "decode" mval (decode bs)
280257
281−assertJsonEncodingExample :: Example -> TestTree
282−assertJsonEncodingExample (Example name bss val _) = testCase name $ do
258+assertJsonEncodingExample :: Example -> Test
259+assertJsonEncodingExample (Example name bss val) = testCase name $ do
283260 assertSomeEqual "encode" bss (encode val)
284261 assertSomeEqual "encode/via value" bss (encode $ toJSON val)
285262assertJsonEncodingExample (MaybeExample name _ _) = testCase name $
tests/Tests.hs+3−5
@@ -1,10 +1,9 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
31module Main (main) where
42
3+import Prelude ()
54import Prelude.Compat
65
7−import Test.Tasty (defaultMain, testGroup)
6+import Test.Framework (defaultMain)
87import qualified DataFamilies.Properties as DF
98import qualified Properties
109import qualified UnitTests
@@ -12,5 +11,4 @@ import qualified UnitTests
1211main :: IO ()
1312main = do
1413 ioTests <- UnitTests.ioTests
15− let allTests = DF.tests : Properties.tests : UnitTests.tests : ioTests
16− defaultMain (testGroup "tests" allTests)
14+ defaultMain (DF.tests : Properties.tests : UnitTests.tests : ioTests)
tests/Types.hs+5−4
@@ -4,16 +4,15 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE GADTs #-}
66{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE NoImplicitPrelude #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
97{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
109
1110module Types (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 (..))
@@ -119,7 +118,9 @@ deriving instance Generic (Sum4 a b c d)
119118deriving instance Generic (Approx a)
120119deriving instance Generic Nullary
121120deriving instance Generic (SomeType a)
121+#if __GLASGOW_HASKELL__ >= 706
122122deriving instance Generic1 SomeType
123+#endif
123124deriving instance Generic OptionField
124125deriving instance Generic EitherTextInt
125126
@@ -151,7 +152,7 @@ instance Hashable a => Hashable (LogScaled a) where
151152 hashWithSalt salt (LogScaled a) = hashWithSalt salt a
152153
153154instance Arbitrary a => Arbitrary (LogScaled a) where
154− arbitrary = LogScaled <$> scale (\x -> intLog2 $ x + 1) arbitrary
155+ arbitrary = fmap LogScaled $ scale (\x -> intLog2 $ x + 1) arbitrary
155156 shrink = fmap LogScaled . shrink . getLogScaled
156157
157158instance ToJSON a => ToJSON (LogScaled a) where
tests/UnitTests.hs+38−256
@@ -1,11 +1,9 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE NoImplicitPrelude #-}
54{-# LANGUAGE OverloadedStrings #-}
65{-# LANGUAGE ScopedTypeVariables #-}
76{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE QuasiQuotes #-}
97
108-- For Data.Aeson.Types.camelTo
119{-# OPTIONS_GHC -fno-warn-deprecations #-}
@@ -21,52 +19,42 @@ module UnitTests
2119 , withEmbeddedJSONTest
2220 ) where
2321
22+import Prelude ()
2423import Prelude.Compat
2524
2625import Control.Monad (forM, forM_)
2726import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)
2827import Data.Aeson.Internal (JSONPathElement(..), formatError)
29−import Data.Aeson.QQ.Simple (aesonQQ)
3028import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
3129import 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)
30+import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null), camelTo, camelTo2, defaultOptions, omitNothingFields, parse)
4031import Data.Char (toUpper)
4132import Data.Either.Compat (isLeft, isRight)
4233import Data.Hashable (hash)
43−import Data.HashMap.Strict (HashMap)
44−import Data.List (sort, isSuffixOf)
34+import Data.List (sort)
4535import Data.Maybe (fromMaybe)
46−import Data.Scientific (Scientific, scientific)
36+import Data.Sequence (Seq)
4737import Data.Tagged (Tagged(..))
4838import Data.Text (Text)
4939import Data.Time (UTCTime)
50−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
40+import Data.Time.Format (parseTime)
41+import Data.Time.Locale.Compat (defaultTimeLocale)
5142import GHC.Generics (Generic)
5243import Instances ()
53−import Numeric.Natural (Natural)
5444import System.Directory (getDirectoryContents)
5545import System.FilePath ((</>), takeExtension, takeFileName)
56−import Test.Tasty (TestTree, testGroup)
57−import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))
46+import Test.Framework (Test, testGroup)
47+import Test.Framework.Providers.HUnit (testCase)
48+import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)
5849import Text.Printf (printf)
5950import UnitTests.NullaryConstructors (nullaryConstructors)
60−import qualified Data.ByteString as S
6151import qualified Data.ByteString.Base16.Lazy as LBase16
6252import qualified Data.ByteString.Lazy.Char8 as L
6353import qualified Data.HashSet as HashSet
64−import qualified Data.HashMap.Lazy as HashMap
6554import qualified Data.Text.Lazy as LT
6655import qualified Data.Text.Lazy.Builder as TLB
6756import qualified Data.Text.Lazy.Encoding as LT
6857import qualified Data.Text.Lazy.Encoding as TLE
69−import qualified Data.Vector as Vector
7058import qualified ErrorMessages
7159import qualified SerializationFormatSpec
7260
@@ -74,7 +62,7 @@ import qualified SerializationFormatSpec
7462import Data.Aeson.Parser.UnescapeFFI ()
7563import Data.Aeson.Parser.UnescapePure ()
7664
77−tests :: TestTree
65+tests :: Test
7866tests = testGroup "unit" [
7967 testGroup "SerializationFormatSpec" SerializationFormatSpec.tests
8068 , testGroup "ErrorMessages" ErrorMessages.tests
@@ -101,8 +89,8 @@ tests = testGroup "unit" [
10189 testCase "example 1" formatErrorExample
10290 ]
10391 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
92+ , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
10493 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
105− , testGroup "Object construction" $ fmap (testCase "-") objectConstruction
10694 , testGroup "Issue #351" $ fmap (testCase "-") issue351
10795 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
10896 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
@@ -111,21 +99,6 @@ tests = testGroup "unit" [
11199 , testCase "Show Options" showOptions
112100 , testGroup "SingleMaybeField" singleMaybeField
113101 , 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− ]
129102 ]
130103
131104roundTripCamel :: String -> Assertion
@@ -218,18 +191,10 @@ utcTimeGood = do
218191 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
219192 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
220193
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−
229194 where
230195 parseWithRead :: String -> LT.Text -> UTCTime
231196 parseWithRead f s =
232− fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s
197+ fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s
233198 parseWithAeson :: LT.Text -> Maybe UTCTime
234199 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]
235200
@@ -245,7 +210,6 @@ utcTimeBad = do
245210 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given
246211 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits
247212 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
249213 where
250214 verifyFailParse (s :: LT.Text) =
251215 let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in
@@ -258,18 +222,6 @@ formatErrorExample =
258222 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
259223 in assertEqual "formatError example" lhs rhs
260224
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−
273225------------------------------------------------------------------------------
274226-- Comparison (.:?) and (.:!)
275227------------------------------------------------------------------------------
@@ -300,6 +252,27 @@ dotColonMark = [
300252 ex2 = "{\"value\": 42 }"
301253 ex3 = "{\"value\": null }"
302254
255+------------------------------------------------------------------------------
256+-- These tests check that JSONPath is tracked correctly
257+-----------------------------------------------------------------------------
258+
259+jsonPath :: [Assertion]
260+jsonPath = [
261+ -- issue #356
262+ assertEqual "Either"
263+ (Left "Error in $[1].Left[1]: expected Bool, encountered Number")
264+ (eitherDecode "[1,{\"Left\":[2,3]}]"
265+ :: Either String (Int, Either (Int, Bool) ()))
266+ -- issue #358
267+ , assertEqual "Seq a"
268+ (Left "Error in $[2]: expected Int, encountered Boolean")
269+ (eitherDecode "[0,1,true]" :: Either String (Seq Int))
270+ , assertEqual "Wibble"
271+ (Left "Error in $.wibbleInt: expected Int, encountered Boolean")
272+ (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"
273+ :: Either String Wibble)
274+ ]
275+
303276------------------------------------------------------------------------------
304277-- Check that the hashes of two equal Value are the same
305278------------------------------------------------------------------------------
@@ -312,18 +285,6 @@ hashableLaws = [
312285 a = object ["223" .= False, "807882556" .= True]
313286 b = object ["807882556" .= True, "223" .= False]
314287
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−
327288-------------------------------------------------------------------------------
328289-- ToJSONKey
329290-------------------------------------------------------------------------------
@@ -384,13 +345,13 @@ issue351 = [
384345-- Comparison between bytestring and text encoders
385346------------------------------------------------------------------------------
386347
387−ioTests :: IO [TestTree]
348+ioTests :: IO [Test]
388349ioTests = do
389350 enc <- encoderComparisonTests
390351 js <- jsonTestSuite
391352 return [enc, js]
392353
393−encoderComparisonTests :: IO TestTree
354+encoderComparisonTests :: IO Test
394355encoderComparisonTests = do
395356 encoderTests <- forM testFiles $ \file0 -> do
396357 let file = "benchmarks/json-data/" ++ file0
@@ -450,7 +411,7 @@ unescapeString = do
450411
451412-- JSONTestSuite
452413
453−jsonTestSuiteTest :: FilePath -> TestTree
414+jsonTestSuiteTest :: FilePath -> Test
454415jsonTestSuiteTest path = testCase fileName $ do
455416 payload <- L.readFile path
456417 let result = eitherDecode payload :: Either String Value
@@ -465,7 +426,7 @@ jsonTestSuiteTest path = testCase fileName $ do
465426-- Build a collection of tests based on the current contents of the
466427-- JSONTestSuite test directories.
467428
468−jsonTestSuite :: IO TestTree
429+jsonTestSuite :: IO Test
469430jsonTestSuite = do
470431 let suitePath = "tests/JSONTestSuite"
471432 let suites = ["test_parsing", "test_transform"]
@@ -540,14 +501,13 @@ showOptions =
540501 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
541502 ++ ", unwrapUnaryRecords = False"
542503 ++ ", tagSingleConstructors = False"
543− ++ ", rejectUnknownFields = False"
544504 ++ "}")
545505 (show defaultOptions)
546506
547507newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }
548508 deriving (Eq, Show, Generic)
549509
550−singleMaybeField :: [TestTree]
510+singleMaybeField :: [Test]
551511singleMaybeField = do
552512 (gName, gToJSON, gToEncoding, gFromJSON) <-
553513 [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))
@@ -574,187 +534,9 @@ withEmbeddedJSONTest :: Assertion
574534withEmbeddedJSONTest =
575535 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
576536
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−
750537deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
751538
752539deriveToJSON defaultOptions ''Foo
753540deriveToJSON1 defaultOptions ''Foo
754541
755542deriveJSON 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 #-}
32
43{-# OPTIONS_GHC -fno-warn-deprecations #-}
54
@@ -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
88
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+2−4
@@ -19,11 +19,9 @@ 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− ;;
2622 hlint)
23+ stack build --fast aeson --stack-yaml stack-nightly.yaml --system-ghc --no-terminal
24+ stack install hlint --stack-yaml stack-nightly.yaml --system-ghc --no-terminal
2725 make lint
2826 ;;
2927esac