on master help sign in
42 files changed+1440−376
since splitsnapshots
unifiedsplit
.gitignore+1 .hlint.yaml+6−1 .travis.yml+34−23 CONTRIBUTING.md+38 Data/Aeson.hs+9 Data/Aeson/Compat.hs−16 Data/Aeson/Parser.hs+11−1 Data/Aeson/Parser/Internal.hs+148−34 Data/Aeson/TH.hs+24−38 Data/Aeson/Types.hs+19 Data/Aeson/Types/Class.hs+5 Data/Aeson/Types/FromJSON.hs+161−84 Data/Aeson/Types/Internal.hs+98−5 Data/Aeson/Types/ToJSON.hs+46−46 Makefile+1−1 aeson.cabal+12−19 attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs−20 attoparsec-iso8601/attoparsec-iso8601.cabal+2−2 benchmarks/AesonEncode.hs+1−1 benchmarks/Compare/JsonBench.hs+2−1 benchmarks/Issue673.hs+1 benchmarks/aeson-benchmarks.cabal+31−28 cabal.project+3−1 changelog.md+56 run-hlint.sh+7 stack-bench.yaml+2−8 stack-ffi-unescape.yaml+2−7 stack-nightly.yaml+2−4 tests/Encoders.hs+38−6 tests/ErrorMessages.hs+27−1 tests/Instances.hs+1−4 tests/Options.hs+11 tests/PropertyGeneric.hs−8 tests/PropertyKeys.hs−3 tests/SerializationFormatSpec.hs−4 tests/Types.hs−2 tests/UnitTests.hs+162−3 tests/UnitTests/NullaryConstructors.hs+5 tests/golden/generic.expected+11−3 travis/cabal_macros.h+448 travis/install.sh+11 travis/script.sh+4−2
.gitignore+1
@@ -5,6 +5,7 @@ dist-newstyle
55cabal.sandbox.config
66.stack-work/
77.stack-work-bench/
8+*.yaml.lock
89
910*.o
1011*.hi
.hlint.yaml+6−1
@@ -3,4 +3,9 @@
33 name: "Reduce duplication"
44 within:
55 - Data.Aeson.Types.ToJSON
6−- ignore: {name: "Eta reduce" }
6+- ignore:
7+ name: "Eta reduce"
8+- ignore:
9+ name: "Use newtype instead of data"
10+ within:
11+ - Data.Aeson.Types.Internal
.travis.yml+34−23
@@ -12,47 +12,58 @@ cache:
1212 - $HOME/.stack
1313 - $HOME/.cabsnap
1414 - $HOME/.cabal/packages
15+ - $HOME/.cabal/store
1516
1617before_cache:
1718 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
18− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
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
1924
2025matrix:
2126 include:
22− - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.3
23− compiler: ": #GHC 8.4.3"
24− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
25− - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-bench.yaml
26− compiler: ": #GHC 8.4.3"
27− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
28− - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-ffi-unescape.yaml
29− compiler: ": #GHC 8.4.3"
30− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
31−
32− - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.1
33− compiler: ": #GHC 8.6.1"
34− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}
35− - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.3
36− compiler: ": #GHC 8.4.3"
37− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
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+
3852 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2
3953 compiler: ": #GHC 8.2.2"
4054 addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
55+
4156 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2
4257 compiler: ": #GHC 8.0.2"
4358 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}
59+
4460 - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3
4561 compiler: ": #GHC 7.10.3"
4662 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
63+
4764 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4
4865 compiler: ": #GHC 7.8.4"
4966 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
50− - env: BUILD=cabal CABALVER=1.18 GHCVER=7.6.3
51− compiler: ": #GHC 7.6.3"
52− addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
53− - env: BUILD=cabal CABALVER=1.18 GHCVER=7.4.2
54− compiler: ": #GHC 7.4.2"
55− addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}
5667
5768before_install:
5869 - unset CC
CONTRIBUTING.md+38
@@ -58,3 +58,41 @@ 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+9
@@ -70,6 +70,11 @@ module Data.Aeson
7070 , ToJSONKeyFunction(..)
7171 , FromJSONKey(..)
7272 , FromJSONKeyFunction(..)
73+ -- *** Generic keys
74+ , GToJSONKey()
75+ , genericToJSONKey
76+ , GFromJSONKey()
77+ , genericFromJSONKey
7378 -- ** Liftings to unary and binary type constructors
7479 , FromJSON1(..)
7580 , parseJSON1
@@ -111,6 +116,10 @@ module Data.Aeson
111116 , SumEncoding(..)
112117 , camelTo2
113118 , defaultTaggedObject
119+ -- ** Options for object keys
120+ , JSONKeyOptions
121+ , keyModifier
122+ , defaultJSONKeyOptions
114123
115124 -- * Inspecting @'Value's@
116125 , withObject
Data/Aeson/Compat.hsdeleted−16
@@ -1,16 +0,0 @@
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/Parser.hs+11−1
@@ -35,10 +35,20 @@ module Data.Aeson.Parser
3535 , value
3636 , jstring
3737 , scientific
38+ -- ** Handling objects with duplicate keys
39+ , jsonWith
40+ , jsonLast
41+ , jsonAccum
42+ , jsonNoDup
3843 -- * Strict parsers
3944 -- $strict
4045 , json'
4146 , value'
47+ -- ** Handling objects with duplicate keys
48+ , jsonWith'
49+ , jsonLast'
50+ , jsonAccum'
51+ , jsonNoDup'
4252 -- * Decoding without FromJSON instances
4353 , decodeWith
4454 , decodeStrictWith
@@ -47,7 +57,7 @@ module Data.Aeson.Parser
4757 ) where
4858
4959
50−import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, scientific, value, value')
60+import Data.Aeson.Parser.Internal
5161
5262-- $lazy
5363--
Data/Aeson/Parser/Internal.hs+148−34
@@ -5,6 +5,10 @@
55#if MIN_VERSION_ghc_prim(0,3,1)
66{-# LANGUAGE MagicHash #-}
77#endif
8+#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706
9+-- Work around a compiler bug
10+{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}
11+#endif
812-- |
913-- Module: Data.Aeson.Parser.Internal
1014-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -21,30 +25,43 @@ module Data.Aeson.Parser.Internal
2125 (
2226 -- * Lazy parsers
2327 json, jsonEOF
28+ , jsonWith
29+ , jsonLast
30+ , jsonAccum
31+ , jsonNoDup
2432 , value
2533 , jstring
2634 , jstring_
2735 , scientific
2836 -- * Strict parsers
2937 , json', jsonEOF'
38+ , jsonWith'
39+ , jsonLast'
40+ , jsonAccum'
41+ , jsonNoDup'
3042 , value'
3143 -- * Helpers
3244 , decodeWith
3345 , decodeStrictWith
3446 , eitherDecodeWith
3547 , eitherDecodeStrictWith
48+ -- ** Handling objects with duplicate keys
49+ , fromListAccum
50+ , parseListNoDup
3651 ) where
3752
3853import Prelude.Compat
3954
4055import Control.Applicative ((<|>))
4156import Control.Monad (void, when)
42−import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
57+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))
4358import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
59+import Data.Function (fix)
4460import Data.Functor.Compat (($>))
4561import Data.Scientific (Scientific)
4662import Data.Text (Text)
47−import Data.Vector as Vector (Vector, empty, fromListN, reverse)
63+import Data.Vector (Vector)
64+import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
4865import qualified Data.Attoparsec.ByteString as A
4966import qualified Data.Attoparsec.Lazy as L
5067import qualified Data.ByteString as B
@@ -76,7 +93,7 @@ import qualified Data.Text.Encoding as TE
7693#define C_n 110
7794#define C_t 116
7895
79−-- | Parse a top-level JSON value.
96+-- | Parse any JSON value.
8097--
8198-- The conversion of a parsed value to a Haskell value is deferred
8299-- until the Haskell value is needed. This may improve performance if
@@ -86,10 +103,15 @@ import qualified Data.Text.Encoding as TE
86103-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
87104-- parsed only object or array types, in conformance with the
88105-- 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'.
89111json :: Parser Value
90112json = value
91113
92−-- | Parse a top-level JSON value.
114+-- | Parse any JSON value.
93115--
94116-- This is a strict version of 'json' which avoids building up thunks
95117-- during parsing; it performs all conversions immediately. Prefer
@@ -98,23 +120,35 @@ json = value
98120-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
99121-- parsed only object or array types, in conformance with the
100122-- 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''.
101128json' :: Parser Value
102129json' = value'
103130
104−object_ :: Parser Value
105−object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
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_ #-}
106138
107−object_' :: Parser Value
108−object_' = {-# SCC "object_'" #-} do
109− !vals <- objectValues jstring' value'
139+object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value
140+object_' mkObject val' = {-# SCC "object_'" #-} do
141+ !vals <- objectValues mkObject jstring' val'
110142 return (Object vals)
111143 where
112144 jstring' = do
113145 !s <- jstring
114146 return s
147+{-# INLINE object_' #-}
115148
116−objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
117−objectValues str val = do
149+objectValues :: ([(Text, Value)] -> Either String Object)
150+ -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
151+objectValues mkObject str val = do
118152 skipSpace
119153 w <- A.peekWord8'
120154 if w == CLOSE_CURLY
@@ -130,16 +164,20 @@ objectValues str val = do
130164 let acc' = (k, v) : acc
131165 if ch == COMMA
132166 then skipSpace >> loop acc'
133− else return (H.fromList acc')
167+ else case mkObject acc' of
168+ Left err -> fail err
169+ Right obj -> pure obj
134170{-# INLINE objectValues #-}
135171
136−array_ :: Parser Value
137−array_ = {-# SCC "array_" #-} Array <$> arrayValues value
172+array_ :: Parser Value -> Parser Value
173+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
174+{-# INLINE array_ #-}
138175
139−array_' :: Parser Value
140−array_' = {-# SCC "array_'" #-} do
141− !vals <- arrayValues value'
176+array_' :: Parser Value -> Parser Value
177+array_' val = {-# SCC "array_'" #-} do
178+ !vals <- arrayValues val
142179 return (Array vals)
180+{-# INLINE array_' #-}
143181
144182arrayValues :: Parser Value -> Parser (Vector Value)
145183arrayValues val = do
@@ -157,42 +195,104 @@ arrayValues val = do
157195 else return (Vector.reverse (Vector.fromListN len (v:acc)))
158196{-# INLINE arrayValues #-}
159197
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.
163−--
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.
198+-- | Parse any JSON value. Synonym of 'json'.
170199value :: Parser Value
171−value = do
200+value = jsonWith (pure . H.fromList)
201+
202+-- | Parse any JSON value.
203+--
204+-- This parser is parameterized by a function to construct an 'Object'
205+-- from a raw list of key-value pairs, where duplicates are preserved.
206+-- The pairs appear in __reverse order__ from the source.
207+--
208+-- ==== __Examples__
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
172237 skipSpace
173238 w <- A.peekWord8'
174239 case w of
175240 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
176− OPEN_CURLY -> A.anyWord8 *> object_
177− OPEN_SQUARE -> A.anyWord8 *> array_
241+ OPEN_CURLY -> A.anyWord8 *> object_ mkObject value_
242+ OPEN_SQUARE -> A.anyWord8 *> array_ value_
178243 C_f -> string "false" $> Bool False
179244 C_t -> string "true" $> Bool True
180245 C_n -> string "null" $> Null
181246 _ | w >= 48 && w <= 57 || w == 45
182247 -> Number <$> scientific
183248 | otherwise -> fail "not a valid json value"
249+{-# INLINE jsonWith #-}
250+
251+-- | Variant of 'json' which keeps only the last occurence of every key.
252+jsonLast :: Parser Value
253+jsonLast = jsonWith (Right . H.fromListWith (const id))
254+
255+-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
256+-- key-value pairs with the same keys.
257+jsonAccum :: Parser Value
258+jsonAccum = jsonWith (Right . fromListAccum)
259+
260+-- | Variant of 'json' which fails if any object contains duplicate keys.
261+jsonNoDup :: Parser Value
262+jsonNoDup = jsonWith parseListNoDup
184263
185−-- | Strict version of 'value'. See also 'json''.
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''.
186282value' :: Parser Value
187−value' = do
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
188288 skipSpace
189289 w <- A.peekWord8'
190290 case w of
191291 DOUBLE_QUOTE -> do
192292 !s <- A.anyWord8 *> jstring_
193293 return (String s)
194− OPEN_CURLY -> A.anyWord8 *> object_'
195− OPEN_SQUARE -> A.anyWord8 *> array_'
294+ OPEN_CURLY -> A.anyWord8 *> object_' mkObject value_
295+ OPEN_SQUARE -> A.anyWord8 *> array_' value_
196296 C_f -> string "false" $> Bool False
197297 C_t -> string "true" $> Bool True
198298 C_n -> string "null" $> Null
@@ -201,6 +301,20 @@ value' = do
201301 !n <- scientific
202302 return (Number n)
203303 | 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
204318
205319-- | Parse a quoted JSON string.
206320jstring :: Parser Text
Data/Aeson/TH.hs+24−38
@@ -135,22 +135,15 @@ import Data.Map (Map)
135135import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
136136import qualified Data.Monoid as Monoid
137137import Data.Set (Set)
138−#if MIN_VERSION_template_haskell(2,8,0)
139138import Language.Haskell.TH hiding (Arity)
140−#else
141−import Language.Haskell.TH
142−#endif
143139import Language.Haskell.TH.Datatype
144−#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
145−import Language.Haskell.TH.Lib (starK)
146−#endif
147140#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
148141import Language.Haskell.TH.Syntax (mkNameG_tc)
149142#endif
150143import Text.Printf (printf)
151144import qualified Data.Aeson.Encoding.Internal as E
152145import qualified Data.Foldable as F (all)
153−import qualified Data.HashMap.Strict as H (lookup, toList)
146+import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)
154147import qualified Data.List.NonEmpty as NE (length, reverse)
155148import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
156149import qualified Data.Semigroup as Semigroup (Option(..))
@@ -929,12 +922,32 @@ parseRecord :: JSONClass
929922 -> Name
930923 -> [Name]
931924 -> Name
925+ -> Bool
932926 -> ExpQ
933−parseRecord jc tvMap argTys opts tName conName fields obj =
927+parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
928+ (if rejectUnknownFields opts
929+ then infixApp checkUnknownRecords [|(>>)|]
930+ else id) $
934931 foldl' (\a b -> infixApp a [|(<*>)|] b)
935932 (infixApp (conE conName) [|(<$>)|] x)
936933 xs
937934 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+ ]
938951 x:xs = [ [|lookupField|]
939952 `appE` dispatchParseJSON jc conName tvMap argTy
940953 `appE` litE (stringL $ show tName)
@@ -1009,7 +1022,7 @@ parseArgs jc tvMap tName opts
10091022 , constructorFields = argTys }
10101023 (Left (_, obj)) = do
10111024 argTys' <- mapM resolveTypeSynonyms argTys
1012− parseRecord jc tvMap argTys' opts tName conName fields obj
1025+ parseRecord jc tvMap argTys' opts tName conName fields obj True
10131026parseArgs jc tvMap tName opts
10141027 info@ConstructorInfo { constructorName = conName
10151028 , constructorVariant = RecordConstructor fields
@@ -1024,7 +1037,7 @@ parseArgs jc tvMap tName opts
10241037 argTys' <- mapM resolveTypeSynonyms argTys
10251038 caseE (varE valName)
10261039 [ match (conP 'Object [varP obj]) (normalB $
1027− parseRecord jc tvMap argTys' opts tName conName fields obj) []
1040+ parseRecord jc tvMap argTys' opts tName conName fields obj False) []
10281041 , matchFailed tName conName "Object"
10291042 ]
10301043
@@ -1590,21 +1603,13 @@ type TyVarMap = Map Name (Name, Name)
15901603-- | Returns True if a Type has kind *.
15911604hasKindStar :: Type -> Bool
15921605hasKindStar VarT{} = True
1593−#if MIN_VERSION_template_haskell(2,8,0)
15941606hasKindStar (SigT _ StarT) = True
1595−#else
1596−hasKindStar (SigT _ StarK) = True
1597−#endif
15981607hasKindStar _ = False
15991608
16001609-- Returns True is a kind is equal to *, or if it is a kind variable.
16011610isStarOrVar :: Kind -> Bool
1602−#if MIN_VERSION_template_haskell(2,8,0)
16031611isStarOrVar StarT = True
16041612isStarOrVar VarT{} = True
1605−#else
1606−isStarOrVar StarK = True
1607−#endif
16081613isStarOrVar _ = False
16091614
16101615-- Generate a list of fresh names with a common prefix, and numbered suffixes.
@@ -1662,9 +1667,7 @@ isTyFamily (ConT n) = do
16621667#else
16631668 FamilyI (FamilyD TypeFam _ _ _) _ -> True
16641669#endif
1665−#if MIN_VERSION_template_haskell(2,9,0)
16661670 FamilyI ClosedTypeFamilyD{} _ -> True
1667−#endif
16681671 _ -> False
16691672isTyFamily _ = return False
16701673
@@ -1692,9 +1695,7 @@ mentionsName = go
16921695 go :: Type -> [Name] -> Bool
16931696 go (AppT t1 t2) names = go t1 names || go t2 names
16941697 go (SigT t _k) names = go t names
1695−#if MIN_VERSION_template_haskell(2,8,0)
16961698 || go _k names
1697−#endif
16981699 go (VarT n) names = n `elem` names
16991700 go _ _ = False
17001701
@@ -1750,23 +1751,14 @@ uncurryTy t = ([], t :| [])
17501751
17511752-- | Like uncurryType, except on a kind level.
17521753uncurryKind :: Kind -> NonEmpty Kind
1753−#if MIN_VERSION_template_haskell(2,8,0)
17541754uncurryKind = snd . uncurryTy
1755−#else
1756−uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
1757−uncurryKind k = k :| []
1758−#endif
17591755
17601756createKindChain :: Int -> Kind
17611757createKindChain = go starK
17621758 where
17631759 go :: Kind -> Int -> Kind
17641760 go k 0 = k
1765−#if MIN_VERSION_template_haskell(2,8,0)
17661761 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)
1767−#else
1768− go k !n = go (ArrowK StarK k) (n - 1)
1769−#endif
17701762
17711763-- | Makes a string literal expression from a constructor's name.
17721764conNameExp :: Options -> ConstructorInfo -> Q Exp
@@ -1820,11 +1812,7 @@ canEtaReduce remaining dropped =
18201812-------------------------------------------------------------------------------
18211813
18221814applySubstitutionKind :: Map Name Kind -> Type -> Type
1823−#if MIN_VERSION_template_haskell(2,8,0)
18241815applySubstitutionKind = applySubstitution
1825−#else
1826−applySubstitutionKind _ t = t
1827−#endif
18281816
18291817substNameWithKind :: Name -> Kind -> Type -> Type
18301818substNameWithKind n k = applySubstitutionKind (M.singleton n k)
@@ -1988,9 +1976,7 @@ data StarKindStatus = NotKindStar
19881976canRealizeKindStar :: Type -> StarKindStatus
19891977canRealizeKindStar t = case t of
19901978 _ | hasKindStar t -> KindStar
1991−#if MIN_VERSION_template_haskell(2,8,0)
19921979 SigT _ (VarT k) -> IsKindVar k
1993−#endif
19941980 _ -> NotKindStar
19951981
19961982-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
Data/Aeson/Types.hs+19
@@ -53,6 +53,12 @@ module Data.Aeson.Types
5353 , coerceFromJSONKeyFunction
5454 , mapFromJSONKeyFunction
5555
56+ -- *** Generic keys
57+ , GToJSONKey()
58+ , genericToJSONKey
59+ , GFromJSONKey()
60+ , genericFromJSONKey
61+
5662 -- ** Liftings to unary and binary type constructors
5763 , FromJSON1(..)
5864 , parseJSON1
@@ -118,6 +124,7 @@ module Data.Aeson.Types
118124 , sumEncoding
119125 , unwrapUnaryRecords
120126 , tagSingleConstructors
127+ , rejectUnknownFields
121128
122129 -- ** Options utilities
123130 , SumEncoding(..)
@@ -125,6 +132,18 @@ module Data.Aeson.Types
125132 , camelTo2
126133 , defaultOptions
127134 , 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
128147 ) where
129148
130149import Prelude.Compat
Data/Aeson/Types/Class.hs+5
@@ -58,6 +58,11 @@ module Data.Aeson.Types.Class
5858 , fromJSONKeyCoerce
5959 , coerceFromJSONKeyFunction
6060 , mapFromJSONKeyFunction
61+ -- ** Generic keys
62+ , GToJSONKey()
63+ , genericToJSONKey
64+ , GFromJSONKey()
65+ , genericFromJSONKey
6166 -- * Object key-value pairs
6267 , KeyValue(..)
6368
Data/Aeson/Types/FromJSON.hs+161−84
@@ -5,19 +5,16 @@
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GADTs #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NamedFieldPuns #-}
98{-# LANGUAGE NoImplicitPrelude #-}
109{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE RecordWildCards #-}
1212{-# LANGUAGE ScopedTypeVariables #-}
1313{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE TupleSections #-}
1415{-# LANGUAGE UndecidableInstances #-}
1516{-# LANGUAGE ViewPatterns #-}
1617
17−#if __GLASGOW_HASKELL__ >= 706
18−{-# LANGUAGE PolyKinds #-}
19−#endif
20−
2118#include "incoherent-compat.h"
2219#include "overlapping-compat.h"
2320
@@ -45,6 +42,9 @@ module Data.Aeson.Types.FromJSON
4542 , coerceFromJSONKeyFunction
4643 , mapFromJSONKeyFunction
4744
45+ , GFromJSONKey()
46+ , genericFromJSONKey
47+
4848 -- * List functions
4949 , listParser
5050
@@ -118,9 +118,9 @@ import GHC.Generics
118118import Numeric.Natural (Natural)
119119import Text.ParserCombinators.ReadP (readP_to_S)
120120import Unsafe.Coerce (unsafeCoerce)
121−import qualified Data.Aeson.Compat as Compat
122121import qualified Data.Aeson.Parser.Time as Time
123122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123+import qualified Data.ByteString.Lazy as L
124124import qualified Data.DList as DList
125125import qualified Data.HashMap.Strict as H
126126import qualified Data.HashSet as HashSet
@@ -155,18 +155,8 @@ import qualified Data.Primitive.UnliftedArray as PM
155155import qualified Data.Primitive.PrimArray as PM
156156#endif
157157
158−#ifndef HAS_COERCIBLE
159−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
160−#endif
161158
162−#if HAS_COERCIBLE
163159import Data.Coerce (Coercible, coerce)
164−coerce' :: Coercible a b => a -> b
165−coerce' = coerce
166−#else
167−coerce' :: a -> b
168−coerce' = unsafeCoerce
169−#endif
170160
171161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
172162parseIndexedJSON p idx value = p value <?> Index idx
@@ -406,6 +396,16 @@ class FromJSON a where
406396-- > newtype SomeId = SomeId { getSomeId :: Text }
407397-- > deriving (Eq,Ord,Hashable,FromJSONKey)
408398--
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+-- @
409409class FromJSONKey a where
410410 -- | Strategy for parsing the key of a map-like container.
411411 fromJSONKey :: FromJSONKeyFunction a
@@ -428,11 +428,7 @@ class FromJSONKey a where
428428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429429-- can be inspected, but cannot be constructed.
430430data CoerceText a where
431−#if HAS_COERCIBLE
432431 CoerceText :: Coercible Text a => CoerceText a
433−#else
434− CoerceText :: CoerceText a
435−#endif
436432
437433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
438434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -452,7 +448,7 @@ data FromJSONKeyFunction a
452448
453449-- | Only law abiding up to interpretation
454450instance Functor FromJSONKeyFunction where
455− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
456452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
457453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
458454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -466,9 +462,7 @@ instance Functor FromJSONKeyFunction where
466462--
467463-- On pre GHC 7.8 this is unconstrainted function.
468464fromJSONKeyCoerce ::
469−#if HAS_COERCIBLE
470465 Coercible Text a =>
471−#endif
472466 FromJSONKeyFunction a
473467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
474468
@@ -476,34 +470,52 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
476470--
477471-- See note on 'fromJSONKeyCoerce'.
478472coerceFromJSONKeyFunction ::
479−#if HAS_COERCIBLE
480473 Coercible a b =>
481−#endif
482474 FromJSONKeyFunction a -> FromJSONKeyFunction b
483−#if HAS_COERCIBLE
484475coerceFromJSONKeyFunction = coerce
485−#else
486−coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
487−coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
488−coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
489−coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
490−#endif
491476
492477{-# RULES
493478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
494479 fmap id x = x
495480 #-}
496−#if HAS_COERCIBLE
497481{-# RULES
498482 "FromJSONKeyCoerce: fmap coerce" forall x .
499483 fmap coerce x = coerceFromJSONKeyFunction x
500484 #-}
501−#endif
502485
503486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
504487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
505488mapFromJSONKeyFunction = fmap
506489
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+
507519-------------------------------------------------------------------------------
508520-- Functions needed for documentation
509521-------------------------------------------------------------------------------
@@ -756,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
756768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
757769-- to the 'Parser' in case of failure.
758770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
759−withBoundedScientific_ whenFail f v@(Number scientific) =
760− if exponent > 1024
771+withBoundedScientific_ whenFail f (Number scientific) =
772+ if exp10 > 1024
761773 then whenFail (fail msg)
762774 else f scientific
763775 where
764− exponent = base10Exponent scientific
765− msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
776+ exp10 = base10Exponent scientific
777+ msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
766778withBoundedScientific_ whenFail _ v =
767779 whenFail (typeMismatch "Number" v)
768780{-# INLINE withBoundedScientific_ #-}
@@ -782,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
782794-- | Decode a nested JSON-encoded string.
783795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
784796withEmbeddedJSON _ innerParser (String txt) =
785− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
786798 where
787799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
788800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -851,7 +863,7 @@ parseFieldMaybe' = (.:!)
851863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
852864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
853865explicitParseField p obj key = case H.lookup key obj of
854− Nothing -> fail $ "key " ++ show key ++ " not present"
866+ Nothing -> fail $ "key " ++ show key ++ " not found"
855867 Just v -> p v <?> Key key
856868{-# INLINE explicitParseField #-}
857869
@@ -910,6 +922,16 @@ type ConName = String
910922contextType :: TypeName -> Parser a -> Parser a
911923contextType = prependContext
912924
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+
913935-- | Add the name of the constructor being parsed to a parser's error messages.
914936contextCons :: ConName -> TypeName -> Parser a -> Parser a
915937contextCons cname tname = prependContext (showCons cname tname)
@@ -1020,41 +1042,46 @@ parseAllNullarySum :: (SumFromString f, ConstructorNames f)
10201042parseAllNullarySum tname opts =
10211043 withText tname $ \tag ->
10221044 maybe (badTag tag) return $
1023− parseSumFromString opts tag
1045+ parseSumFromString modifier tag
10241046 where
1025− badTag tag = failWithCTags tname opts $ \cnames ->
1047+ badTag tag = failWithCTags tname modifier $ \cnames ->
10261048 "expected one of the tags " ++ show cnames ++
10271049 ", but found tag " ++ show tag
1050+ modifier = constructorTagModifier opts
10281051
10291052-- | Fail with an informative error message about a mismatched tag.
10301053-- The error message is parameterized by the list of expected tags,
10311054-- to be inferred from the result type of the parser.
10321055failWithCTags
1033− :: forall f a. ConstructorNames f
1034− => TypeName -> Options -> ([String] -> String) -> Parser (f a)
1035−failWithCTags tname opts f =
1056+ :: forall f a t. ConstructorNames f
1057+ => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1058+failWithCTags tname modifier f =
10361059 contextType tname . fail $ f cnames
10371060 where
1038− cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])
1061+ cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
10391062
10401063class SumFromString f where
1041− parseSumFromString :: Options -> Text -> Maybe (f a)
1064+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
10421065
10431066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
10441067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
10451068 (R1 <$> parseSumFromString opts key)
10461069
10471070instance (Constructor c) => SumFromString (C1 c U1) where
1048− parseSumFromString opts key | key == name = Just $ M1 U1
1049− | otherwise = Nothing
1050− where
1051− name = pack $ constructorTagModifier opts $
1052− conName (undefined :: M1 _i c _f _p)
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
10531080
10541081-- | List of all constructor tags.
1055−constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]
1056−constructorTags opts =
1057− fmap DList.toList (constructorNames' (constructorTagModifier opts))
1082+constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1083+constructorTags modifier =
1084+ fmap DList.toList (constructorNames' modifier)
10581085
10591086-- | List of all constructor names of an ADT, after a given conversion
10601087-- function. (Better inlining.)
@@ -1075,9 +1102,16 @@ instance Constructor c => ConstructorNames (C1 c a) where
10751102 where
10761103 cname = conName (undefined :: M1 _i c _f _p)
10771104
1078−--------------------------------------------------------------------------------
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
10791111
1080−parseNonAllNullarySum :: ( FromPair arity f
1112+--------------------------------------------------------------------------------
1113+parseNonAllNullarySum :: forall f c arity.
1114+ ( FromPair arity f
10811115 , FromTaggedObject arity f
10821116 , FromUntaggedValue arity f
10831117 , ConstructorNames f
@@ -1087,7 +1121,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
10871121 case sumEncoding opts of
10881122 TaggedObject{..} ->
10891123 withObject tname $ \obj -> do
1090− tag <- contextType tname $ obj .: tagKey
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
10911125 fromMaybe (badTag tag <?> Key tagKey) $
10921126 parseFromTaggedObject (tag :* contentsFieldName :* p) obj
10931127 where
@@ -1095,6 +1129,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
10951129 badTag tag = failWith_ $ \cnames ->
10961130 "expected tag field to be one of " ++ show cnames ++
10971131 ", but found tag " ++ show tag
1132+ cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
10981133
10991134 ObjectWithSingleField ->
11001135 withObject tname $ \obj -> case H.toList obj of
@@ -1126,7 +1161,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11261161
11271162 UntaggedValue -> parseUntaggedValue p
11281163 where
1129− failWith_ = failWithCTags tname opts
1164+ failWith_ = failWithCTags tname (constructorTagModifier opts)
11301165
11311166--------------------------------------------------------------------------------
11321167
@@ -1166,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
11661201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
11671202 -> Object -> Tagged isRecord (Parser (f a))
11681203
1169−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
11701205 -- Records are unpacked in the tagged object
1171− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
11721207
11731208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
11741209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1209,11 +1244,11 @@ instance OVERLAPPING_
12091244 ) => ConsFromJSON' arity (S1 s a) True where
12101245 consParseJSON' p@(cname :* tname :* opts :* fargs)
12111246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1212− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12131248
12141249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12151250 consParseJSON' p@(cname :* tname :* _) =
1216− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12171252
12181253instance OVERLAPPING_
12191254 ConsFromJSON' arity U1 False where
@@ -1239,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
12391274
12401275--------------------------------------------------------------------------------
12411276
1277+class FieldNames f where
1278+ fieldNames :: f a -> [Text] -> [Text]
1279+
1280+instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
1281+ fieldNames _ =
1282+ fieldNames (undefined :: a x) .
1283+ fieldNames (undefined :: b y)
1284+
1285+instance (Selector s) => FieldNames (S1 s f) where
1286+ fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1287+
12421288class RecordFromJSON arity f where
12431289 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'
12441313 :: ConName :* TypeName :* Options :* FromArgs arity a
12451314 -> Object -> Parser (f a)
12461315
1247−instance ( RecordFromJSON arity a
1248− , RecordFromJSON arity b
1249− ) => RecordFromJSON arity (a :*: b) where
1250− recordParseJSON p obj =
1251− (:*:) <$> recordParseJSON p obj
1252− <*> recordParseJSON p obj
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
12531322
12541323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1255− RecordFromJSON arity (S1 s a) where
1256− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
12571326 fv <- contextCons cname tname (obj .: label)
12581327 M1 <$> gParseJSON opts fargs fv <?> Key label
12591328 where
@@ -1261,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
12611330 sname = selName (undefined :: M1 _i s _f _p)
12621331
12631332instance INCOHERENT_ (Selector s, FromJSON a) =>
1264− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1265− recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1333+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1334+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
12661335 where
12671336 label = fieldLabelModifier opts sname
12681337 sname = selName (undefined :: M1 _i s _f _p)
12691338
12701339-- Parse an Option like a Maybe.
12711340instance INCOHERENT_ (Selector s, FromJSON a) =>
1272− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1273− recordParseJSON p obj = wrap <$> recordParseJSON p obj
1341+ RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342+ recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
12741343 where
12751344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
12761345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1507,12 +1576,22 @@ instance FromJSONKey Float where
15071576 _ -> Scientific.toRealFloat <$> parseScientificText t
15081577
15091578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1510− parseJSON = withObject "Rational" $ \obj -> do
1511− numerator <- obj .: "numerator"
1512− denominator <- obj .: "denominator"
1513− if denominator == 0
1514− then fail "Ratio denominator was 0"
1515− else pure $ numerator % denominator
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
15161595 {-# INLINE parseJSON #-}
15171596
15181597-- | This instance includes a bounds check to prevent maliciously
@@ -1663,7 +1742,7 @@ instance FromJSON1 NonEmpty where
16631742 liftParseJSON p _ = withArray "NonEmpty" $
16641743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
16651744 where
1666− ne [] = fail "parsing NonEmpty failed, unpexpected empty list"
1745+ ne [] = fail "parsing NonEmpty failed, unexpected empty list"
16671746 ne (x:xs) = pure (x :| xs)
16681747 {-# INLINE liftParseJSON #-}
16691748
@@ -1927,7 +2006,6 @@ instance FromJSON DotNetTime where
19272006-- primitive
19282007-------------------------------------------------------------------------------
19292008
1930−#if MIN_VERSION_base(4,7,0)
19312009instance FromJSON a => FromJSON (PM.Array a) where
19322010 -- note: we could do better than this if vector exposed the data
19332011 -- constructor in Data.Vector.
@@ -1945,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
19452023 parseJSON = fmap Exts.fromList . parseJSON
19462024#endif
19472025#endif
1948−#endif
19492026
19502027-------------------------------------------------------------------------------
19512028-- time
Data/Aeson/Types/Internal.hs+98−5
@@ -49,6 +49,8 @@ module Data.Aeson.Types.Internal
4949 , parserThrowError
5050 , parserCatchError
5151 , formatError
52+ , formatPath
53+ , formatRelativePath
5254 , (<?>)
5355 -- * Constructors and accessors
5456 , object
@@ -62,11 +64,14 @@ module Data.Aeson.Types.Internal
6264 , sumEncoding
6365 , unwrapUnaryRecords
6466 , tagSingleConstructors
67+ , rejectUnknownFields
6568 )
6669
6770 , SumEncoding(..)
71+ , JSONKeyOptions(keyModifier)
6872 , defaultOptions
6973 , defaultTaggedObject
74+ , defaultJSONKeyOptions
7075
7176 -- * Used for changing CamelCase names into something else.
7277 , camelTo
@@ -97,6 +102,7 @@ import Data.Time.Format (FormatTime)
97102import Data.Typeable (Typeable)
98103import Data.Vector (Vector)
99104import GHC.Generics (Generic)
105+import qualified Control.Monad as Monad
100106import qualified Control.Monad.Fail as Fail
101107import qualified Data.HashMap.Strict as H
102108import qualified Data.Scientific as S
@@ -150,7 +156,7 @@ instance Functor Result where
150156 fmap _ (Error err) = Error err
151157 {-# INLINE fmap #-}
152158
153−instance Monad IResult where
159+instance Monad.Monad IResult where
154160 return = pure
155161 {-# INLINE return #-}
156162
@@ -167,7 +173,7 @@ instance Fail.MonadFail IResult where
167173 fail err = IError [] err
168174 {-# INLINE fail #-}
169175
170−instance Monad Result where
176+instance Monad.Monad Result where
171177 return = pure
172178 {-# INLINE return #-}
173179
@@ -286,7 +292,7 @@ newtype Parser a = Parser {
286292 -> f r
287293 }
288294
289−instance Monad Parser where
295+instance Monad.Monad Parser where
290296 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks
291297 in runParser m path kf ks'
292298 {-# INLINE (>>=) #-}
@@ -455,7 +461,17 @@ parseEither m v = runParser (m v) [] onError Right
455461-- | Annotate an error message with a
456462-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.
457463formatError :: JSONPath -> String -> String
458−formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
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
459475 where
460476 format :: String -> JSONPath -> String
461477 format pfx [] = pfx
@@ -568,6 +584,39 @@ data Options = Options
568584 -- ^ If 'True' record fields with a 'Nothing' value will be
569585 -- omitted from the resulting object. If 'False' the resulting
570586 -- 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+ -- @
571620 , sumEncoding :: SumEncoding
572621 -- ^ Specifies how to encode constructors of a sum datatype.
573622 , unwrapUnaryRecords :: Bool
@@ -576,10 +625,14 @@ data Options = Options
576625 , tagSingleConstructors :: Bool
577626 -- ^ Encode types with a single constructor as sums,
578627 -- 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.
579632 }
580633
581634instance Show Options where
582− show (Options f c a o s u t) =
635+ show (Options f c a o s u t r) =
583636 "Options {"
584637 ++ intercalate ", "
585638 [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -589,6 +642,7 @@ instance Show Options where
589642 , "sumEncoding = " ++ show s
590643 , "unwrapUnaryRecords = " ++ show u
591644 , "tagSingleConstructors = " ++ show t
645+ , "rejectUnknownFields = " ++ show r
592646 ]
593647 ++ "}"
594648
@@ -632,6 +686,33 @@ data SumEncoding =
632686 -- contents of the constructor.
633687 deriving (Eq, Show)
634688
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+
635716-- | Default encoding 'Options':
636717--
637718-- @
@@ -643,6 +724,7 @@ data SumEncoding =
643724-- , 'sumEncoding' = 'defaultTaggedObject'
644725-- , 'unwrapUnaryRecords' = False
645726-- , 'tagSingleConstructors' = False
727+-- , 'rejectUnknownFields' = False
646728-- }
647729-- @
648730defaultOptions :: Options
@@ -654,6 +736,7 @@ defaultOptions = Options
654736 , sumEncoding = defaultTaggedObject
655737 , unwrapUnaryRecords = False
656738 , tagSingleConstructors = False
739+ , rejectUnknownFields = False
657740 }
658741
659742-- | Default 'TaggedObject' 'SumEncoding' options:
@@ -670,6 +753,16 @@ defaultTaggedObject = TaggedObject
670753 , contentsFieldName = "contents"
671754 }
672755
756+-- | Default 'JSONKeyOptions':
757+--
758+-- @
759+-- defaultJSONKeyOptions = 'JSONKeyOptions'
760+-- { 'keyModifier' = 'id'
761+-- }
762+-- @
763+defaultJSONKeyOptions :: JSONKeyOptions
764+defaultJSONKeyOptions = JSONKeyOptions id
765+
673766-- | Converts from CamelCase to another lower case, interspersing
674767-- the character between all capital letters and their previous
675768-- entries, except those capital letters that appear together,
Data/Aeson/Types/ToJSON.hs+46−46
@@ -5,19 +5,15 @@
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE FunctionalDependencies #-}
77{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE NamedFieldPuns #-}
98{-# LANGUAGE NoImplicitPrelude #-}
109{-# LANGUAGE OverloadedStrings #-}
1110{-# LANGUAGE PatternGuards #-}
11+{-# LANGUAGE PolyKinds #-}
1212{-# LANGUAGE RecordWildCards #-}
1313{-# LANGUAGE ScopedTypeVariables #-}
1414{-# LANGUAGE TypeOperators #-}
1515{-# LANGUAGE UndecidableInstances #-}
1616
17−#if __GLASGOW_HASKELL__ >= 706
18−{-# LANGUAGE PolyKinds #-}
19−#endif
20−
2117#include "overlapping-compat.h"
2218#include "incoherent-compat.h"
2319
@@ -47,6 +43,10 @@ module Data.Aeson.Types.ToJSON
4743 , ToJSONKeyFunction(..)
4844 , toJSONKeyText
4945 , contramapToJSONKeyFunction
46+
47+ , GToJSONKey()
48+ , genericToJSONKey
49+
5050 -- * Object key-value pairs
5151 , KeyValue(..)
5252 , KeyValuePair(..)
@@ -100,7 +100,6 @@ import GHC.Generics
100100import Numeric.Natural (Natural)
101101import qualified Data.Aeson.Encoding as E
102102import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)
103−import qualified Data.ByteString as S
104103import qualified Data.ByteString.Lazy as L
105104import qualified Data.DList as DList
106105import qualified Data.HashMap.Strict as H
@@ -141,14 +140,6 @@ import qualified Data.Primitive.UnliftedArray as PM
141140import qualified Data.Primitive.PrimArray as PM
142141#endif
143142
144−#if !(MIN_VERSION_bytestring(0,10,0))
145−import Foreign.ForeignPtr (withForeignPtr)
146−import Foreign.Marshal.Utils (copyBytes)
147−import Foreign.Ptr (plusPtr)
148−import qualified Data.ByteString.Internal as S
149−import qualified Data.ByteString.Lazy.Internal as L
150−#endif
151−
152143toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
153144toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)
154145{-# INLINE toJSONPair #-}
@@ -411,7 +402,7 @@ instance KeyValue Object where
411402-- newtype wrapper around 'Text'. The recommended approach is to use
412403-- generalized newtype deriving:
413404--
414−-- > newtype RecordId = RecordId { getRecordId :: Text}
405+-- > newtype RecordId = RecordId { getRecordId :: Text }
415406-- > deriving (Eq,Ord,ToJSONKey)
416407--
417408-- Then we may write:
@@ -426,8 +417,18 @@ instance KeyValue Object where
426417--
427418-- It is possible to get the 'ToJSONKey' instance for free as we did
428419-- with 'Foo'. However, in this case, we have a natural way to go to
429−-- and from 'Text' that does not require any escape sequences. So, in
430−-- this example, 'ToJSONKeyText' will be used instead of 'ToJSONKeyValue'.
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+--
431432-- The 'Show' instance can be used to help write 'ToJSONKey':
432433--
433434-- > instance ToJSONKey Color where
@@ -502,7 +503,7 @@ toJSONKeyTextEnc e = ToJSONKeyText tot e
502503 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
503504 tot = T.dropAround (== '"')
504505 . T.decodeLatin1
505− . lazyToStrictByteString
506+ . L.toStrict
506507 . E.encodingToLazyByteString
507508 . e
508509
@@ -515,6 +516,29 @@ contramapToJSONKeyFunction h x = case x of
515516 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)
516517 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)
517518
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+
518542-------------------------------------------------------------------------------
519543-- Lifings of FromJSON and ToJSON to unary and binary type constructors
520544-------------------------------------------------------------------------------
@@ -944,6 +968,9 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where
944968instance (Constructor c) => GetConName (C1 c a) where
945969 getConName = conName
946970
971+-- For genericToJSONKey
972+instance GetConName a => GetConName (D1 d a) where
973+ getConName (M1 x) = getConName x
947974
948975--------------------------------------------------------------------------------
949976
@@ -1943,7 +1970,6 @@ formatMillis = take 3 . formatTime defaultTimeLocale "%q"
19431970-- primitive
19441971-------------------------------------------------------------------------------
19451972
1946−#if MIN_VERSION_base(4,7,0)
19471973instance ToJSON a => ToJSON (PM.Array a) where
19481974 -- note: we could do better than this if vector exposed the data
19491975 -- constructor in Data.Vector.
@@ -1965,7 +1991,6 @@ instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where
19651991 toEncoding = toEncoding . Exts.toList
19661992#endif
19671993#endif
1968−#endif
19691994
19701995-------------------------------------------------------------------------------
19711996-- time
@@ -2015,7 +2040,7 @@ stringEncoding :: Encoding' Text -> Value
20152040stringEncoding = String
20162041 . T.dropAround (== '"')
20172042 . T.decodeLatin1
2018− . lazyToStrictByteString
2043+ . L.toStrict
20192044 . E.encodingToLazyByteString
20202045{-# INLINE stringEncoding #-}
20212046
@@ -2822,31 +2847,6 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
28222847 toEncoding = toEncoding2
28232848 {-# INLINE toEncoding #-}
28242849
2825−-------------------------------------------------------------------------------
2826−-- pre-bytestring-0.10 compatibility
2827−-------------------------------------------------------------------------------
2828−
2829−{-# INLINE lazyToStrictByteString #-}
2830−lazyToStrictByteString :: L.ByteString -> S.ByteString
2831−#if MIN_VERSION_bytestring(0,10,0)
2832−lazyToStrictByteString = L.toStrict
2833−#else
2834−lazyToStrictByteString = packChunks
2835−
2836−-- packChunks is taken from the blaze-builder package.
2837−
2838−-- | Pack the chunks of a lazy bytestring into a single strict bytestring.
2839−packChunks :: L.ByteString -> S.ByteString
2840−packChunks lbs =
2841− S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)
2842− where
2843− copyChunks L.Empty _pf = return ()
2844− copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do
2845− withForeignPtr fpbuf $ \pbuf ->
2846− copyBytes pf (pbuf `plusPtr` o) l
2847− copyChunks lbs' (pf `plusPtr` l)
2848−#endif
2849−
28502850--------------------------------------------------------------------------------
28512851
28522852-- | Wrap a list of pairs as an object.
Makefile+1−1
@@ -1,2 +1,2 @@
11lint:
2− hlint --cpp-include include/ --cpp-file .stack-work/dist/*/*Cabal-*/build/autogen/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/
2+ ./run-hlint.sh --cpp-include include/ --cpp-file travis/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/
aeson.cabal+12−19
@@ -1,5 +1,5 @@
11name: aeson
2−version: 1.4.3.0
2+version: 1.4.6.0
33license: BSD3
44license-file: LICENSE
55category: Text, Web, JSON
@@ -88,7 +88,6 @@ library
8888 Data.Aeson.Encode
8989
9090 other-modules:
91− Data.Aeson.Compat
9291 Data.Aeson.Encoding.Builder
9392 Data.Aeson.Internal.Functions
9493 Data.Aeson.Parser.Unescape
@@ -103,28 +102,23 @@ library
103102
104103 -- GHC bundled libs
105104 build-depends:
106− base >= 4.5.0.0 && < 5,
107− containers >= 0.4.2.1 && < 0.7,
105+ base >= 4.7.0.0 && < 5,
106+ bytestring >= 0.10.4.0 && < 0.11,
107+ containers >= 0.5.5.1 && < 0.7,
108108 deepseq >= 1.3.0.0 && < 1.5,
109109 ghc-prim >= 0.2 && < 0.6,
110− template-haskell >= 2.7.0.0 && < 2.15,
110+ template-haskell >= 2.9.0.0 && < 2.16,
111111 text >= 1.2.3.0 && < 1.3,
112− time >= 1.4 && < 1.9
112+ time >= 1.4 && < 1.10
113113
114114 if impl(ghc >= 8.0)
115115 build-depends: bytestring >= 0.10.8.1
116116
117117 -- Compat
118118 build-depends:
119− base-compat >= 0.9.1 && < 0.11,
119+ base-compat >= 0.9.1 && < 0.12,
120120 time-compat >= 1.9.2.2 && < 1.10
121121
122− if flag(bytestring-builder)
123− build-depends: bytestring >= 0.9.2.1 && < 0.10.4,
124− bytestring-builder >= 0.10.4 && < 1
125− else
126− build-depends: bytestring >= 0.10.4 && < 0.11
127−
128122 if !impl(ghc >= 8.6)
129123 build-depends:
130124 contravariant >=1.4.1 && <1.6
@@ -132,7 +126,7 @@ library
132126 if !impl(ghc >= 8.0)
133127 -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9
134128 build-depends:
135− semigroups >= 0.18.5 && < 0.19,
129+ semigroups >= 0.18.5 && < 0.20,
136130 transformers >= 0.3.0.0 && < 0.6,
137131 transformers-compat >= 0.6.2 && < 0.7,
138132 fail == 4.9.*
@@ -154,10 +148,9 @@ library
154148 build-depends:
155149 attoparsec >= 0.13.2.2 && < 0.14,
156150 dlist >= 0.8.0.4 && < 0.9,
157− hashable >= 1.2.7.0 && < 1.3,
151+ hashable >= 1.2.7.0 && < 1.4,
158152 scientific >= 0.3.6.2 && < 0.4,
159153 th-abstraction >= 0.2.8.0 && < 0.4,
160− time-locale-compat >= 0.1.1.5 && < 0.2,
161154 uuid-types >= 1.0.3 && < 1.1,
162155 vector >= 0.12.0.1 && < 0.13
163156
@@ -226,9 +219,9 @@ test-suite tests
226219 containers,
227220 directory,
228221 dlist,
229− Diff,
222+ Diff >= 0.4 && < 0.5,
230223 filepath,
231− generic-deriving >= 1.10 && < 1.13,
224+ generic-deriving >= 1.10 && < 1.14,
232225 ghc-prim >= 0.2,
233226 hashable >= 1.2.4.0,
234227 scientific,
@@ -254,7 +247,7 @@ test-suite tests
254247
255248 if !impl(ghc >= 8.0)
256249 build-depends:
257− semigroups >= 0.18.2 && < 0.19,
250+ semigroups >= 0.18.2 && < 0.20,
258251 transformers >= 0.2.2.0,
259252 transformers-compat >= 0.3
260253
attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs−20
@@ -29,16 +29,8 @@ import Data.Time.Clock (diffTimeToPicoseconds)
2929
3030#endif
3131
32−#if MIN_VERSION_base(4,7,0)
33−
3432import Data.Fixed (Pico, Fixed(MkFixed))
3533
36−#else
37−
38−import Data.Fixed (Pico)
39−
40−#endif
41−
4234#if !MIN_VERSION_time(1,6,0)
4335
4436diffTimeToPicoseconds :: DiffTime -> Integer
@@ -46,24 +38,12 @@ diffTimeToPicoseconds = unsafeCoerce
4638
4739#endif
4840
49−#if MIN_VERSION_base(4,7,0)
50−
5141toPico :: Integer -> Pico
5242toPico = MkFixed
5343
5444fromPico :: Pico -> Integer
5545fromPico (MkFixed i) = i
5646
57−#else
58−
59−toPico :: Integer -> Pico
60−toPico = unsafeCoerce
61−
62−fromPico :: Pico -> Integer
63−fromPico = unsafeCoerce
64−
65−#endif
66−
6747-- | Like TimeOfDay, but using a fixed-width integer for seconds.
6848data TimeOfDay64 = TOD {-# UNPACK #-} !Int
6949 {-# UNPACK #-} !Int
attoparsec-iso8601/attoparsec-iso8601.cabal+2−2
@@ -36,8 +36,8 @@ library
3636 Data.Attoparsec.Time
3737 build-depends:
3838 attoparsec >= 0.13.0.1,
39− base >= 4.5 && < 5,
40− base-compat >= 0.9.1 && < 0.11,
39+ base >= 4.7 && < 5,
40+ base-compat >= 0.9.1 && < 0.12,
4141 text >= 1.1.1.0,
4242 time >= 1.1.1.4
4343
benchmarks/AesonEncode.hs+1−1
@@ -7,7 +7,7 @@ module Main (main) where
77import Prelude.Compat
88
99import Control.DeepSeq
10−import Control.Monad
10+import Control.Monad (forM_)
1111import Data.Aeson
1212import Data.Attoparsec.ByteString (IResult(..), parseWith)
1313import Data.Char (isDigit)
benchmarks/Compare/JsonBench.hs+2−1
@@ -20,6 +20,7 @@ import Data.Aeson ((.:))
2020import Data.Monoid ((<>))
2121import Data.Text (Text)
2222import Typed.Common (load)
23+import qualified Control.Monad.Fail as Fail
2324import qualified Data.Aeson as Aeson
2425import qualified Data.BufferBuilder.Json as Json
2526
@@ -82,7 +83,7 @@ genderTable = [("male", Male), ("female", Female)]
8283fruitTable :: [(Text, Fruit)]
8384fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]
8485
85−enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum
86+enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum
8687enumFromJson enumName table extract v = do
8788 s <- extract v
8889 case lookup s table of
benchmarks/Issue673.hs+1
@@ -18,6 +18,7 @@ import Criterion.Main
1818import Prelude.Compat
1919import Data.Int (Int64)
2020import Data.Scientific (Scientific)
21+import Data.Semigroup ((<>))
2122import Data.Aeson.Parser (scientific)
2223
2324import qualified Data.Attoparsec.ByteString.Lazy as AttoL
benchmarks/aeson-benchmarks.cabal+31−28
@@ -28,45 +28,42 @@ library
2828 hs-source-dirs: .. ../ffi ../pure ../attoparsec-iso8601
2929 c-sources: ../cbits/unescape_string.c
3030 build-depends:
31− attoparsec >= 0.13.0.1,
32− base == 4.*,
33− base-compat >= 0.9.1 && <0.11,
34− time-locale-compat >=0.1.1 && <0.2,
31+ attoparsec,
32+ base,
33+ base-compat,
3534 containers,
3635 deepseq,
37− dlist >= 0.2,
38− fail == 4.9.*,
39− ghc-prim >= 0.2,
40− hashable >= 1.1.2.0,
36+ dlist,
37+ fail,
38+ ghc-prim,
39+ hashable,
4140 mtl,
42− primitive >= 0.6.1,
43− scientific >= 0.3.4.7 && < 0.4,
41+ primitive,
42+ scientific,
4443 syb,
45− tagged >=0.8.3 && <0.9,
46− template-haskell >= 2.4,
47− text >= 1.2.3,
48− th-abstraction >= 0.2.2 && < 0.4,
44+ tagged,
45+ template-haskell,
46+ text,
47+ th-abstraction,
4948 time-compat,
5049 time,
5150 transformers,
52− unordered-containers >= 0.2.3.0,
53− uuid-types >= 1.0.3 && <1.1,
54− vector >= 0.7.1
55−
56− if !impl(ghc >= 7.10)
57− -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8
58− build-depends: nats >= 1 && < 1.2
51+ unordered-containers,
52+ uuid-types,
53+ vector
5954
60− if impl(ghc >=7.8)
61− cpp-options: -DHAS_COERCIBLE
55+ if !impl(ghc >= 8.6)
56+ build-depends: contravariant
6257
6358 if !impl(ghc >= 8.0)
6459 -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9
65− build-depends: semigroups >= 0.18.2 && < 0.19
60+ build-depends: semigroups,
61+ transformers-compat
6662
67− if !impl(ghc >= 8.6)
68− build-depends:
69− contravariant >=1.4.1 && <1.6
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
7067
7168 include-dirs: ../include
7269
@@ -75,7 +72,6 @@ library
7572
7673 exposed-modules:
7774 Data.Aeson
78− Data.Aeson.Compat
7975 Data.Aeson.Encoding
8076 Data.Aeson.Encoding.Builder
8177 Data.Aeson.Encoding.Internal
@@ -179,6 +175,9 @@ executable aeson-benchmark-compare
179175 Compare.JsonBuilder
180176 build-depends:
181177 json-builder
178+ if impl(ghc < 8.0)
179+ build-depends:
180+ semigroups
182181
183182executable aeson-benchmark-micro
184183 default-language: Haskell2010
@@ -225,6 +224,8 @@ executable aeson-benchmark-typed
225224 bytestring-builder >= 0.10.4 && < 1
226225 else
227226 build-depends: bytestring >= 0.10.4
227+ if impl(ghc < 8.0)
228+ build-depends: semigroups
228229
229230executable aeson-benchmark-compare-with-json
230231 default-language: Haskell2010
@@ -340,3 +341,5 @@ executable aeson-issue-673
340341 scientific,
341342 base-compat,
342343 criterion >= 1.0
344+ if impl(ghc < 8.0)
345+ build-depends: semigroups
cabal.project+3−1
@@ -1,3 +1,5 @@
11with-compiler: ghc
22packages: .
3−packages: attoparsec-iso8601, benchmarks
3+packages: attoparsec-iso8601
4+-- packages: benchmarks
5+tests: true
changelog.md+56
@@ -1,5 +1,61 @@
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+
359### 1.4.3.0
460* Improve error messages for FromJSON in existing instances and GHC Generic implementation. Thanks to Xia Li-Yao & Igor Pashev.
561* Tweak error-reporting combinators and their documentation. Thanks to Xia Li-Yao.
run-hlint.shnew file+7
@@ -0,0 +1,7 @@
1+#!/bin/bash
2+
3+if hash hlint 2>/dev/null; then
4+ hlint "$@"
5+else
6+ ./hlint.sh "$@"
7+fi
stack-bench.yaml+2−8
@@ -1,4 +1,4 @@
1−resolver: lts-12.26
1+resolver: nightly-2019-09-21
22# We use aeson in the snapshot to
33# - avoid recompilation of criterion
44# - compare against it
@@ -9,10 +9,4 @@ resolver: lts-12.26
99work-dir: .stack-work-bench
1010packages:
1111- benchmarks
12−extra-deps:
13−- base-orphans-0.8.1
14−- hashable-time-0.2.0.1
15−- QuickCheck-2.13.1
16−- quickcheck-instances-0.3.21
17−- splitmix-0.0.2
18−- time-compat-1.9.2.2
12+extra-deps: []
stack-ffi-unescape.yaml+2−7
@@ -1,4 +1,4 @@
1−resolver: lts-12.26
1+resolver: nightly-2019-09-21
22packages:
33- '.'
44flags:
@@ -6,9 +6,4 @@ flags:
66 fast: true
77 cffi: true
88extra-deps:
9−- base-orphans-0.8.1
10−- hashable-time-0.2.0.1
11−- QuickCheck-2.13.1
12−- quickcheck-instances-0.3.21
13−- splitmix-0.0.2
14−- time-compat-1.9.2.2
9+- Diff-0.4.0
stack-nightly.yaml+2−4
@@ -1,4 +1,4 @@
1−resolver: nightly-2019-05-13
1+resolver: nightly-2019-10-14
22packages:
33- '.'
44- attoparsec-iso8601
@@ -8,6 +8,4 @@ flags:
88 attoparsec-iso8601:
99 fast: true
1010extra-deps:
11−- hlint-2.1.18
12−- time-compat-1.9.2.2
13−- quickcheck-instances-0.3.21
11+- generic-deriving-1.12.4
tests/Encoders.hs+38−6
@@ -6,6 +6,7 @@
66module Encoders (module Encoders) where
77
88import Prelude.Compat
9+import Data.Text (Text)
910
1011import Data.Aeson.TH
1112import Data.Aeson.Types
@@ -96,6 +97,18 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle
9697gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
9798gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
9899
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"
99112
100113--------------------------------------------------------------------------------
101114-- SomeType encoders/decoders
@@ -175,7 +188,6 @@ gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray
175188gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)
176189gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
177190
178−#if __GLASGOW_HASKELL__ >= 706
179191gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a
180192gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray
181193
@@ -184,7 +196,6 @@ gSomeTypeLiftToJSON2ElemArray = genericLiftToJSON opts2ElemArray
184196
185197gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a
186198gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray
187−#endif
188199
189200
190201gSomeTypeToJSONTaggedObject :: SomeType Int -> Value
@@ -196,7 +207,6 @@ gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject
196207gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)
197208gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
198209
199−#if __GLASGOW_HASKELL__ >= 706
200210gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a
201211gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject
202212
@@ -205,7 +215,6 @@ gSomeTypeLiftToJSONTaggedObject = genericLiftToJSON optsTaggedObject
205215
206216gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a
207217gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject
208−#endif
209218
210219
211220gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value
@@ -217,7 +226,6 @@ gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingl
217226gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)
218227gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
219228
220−#if __GLASGOW_HASKELL__ >= 706
221229gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a
222230gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField
223231
@@ -226,7 +234,6 @@ gSomeTypeLiftToJSONObjectWithSingleField = genericLiftToJSON optsObjectWithSingl
226234
227235gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a
228236gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField
229−#endif
230237
231238
232239gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value
@@ -236,6 +243,31 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding
236243gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields
237244
238245
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+
239271--------------------------------------------------------------------------------
240272-- Option fields
241273--------------------------------------------------------------------------------
tests/ErrorMessages.hs+27−1
@@ -13,7 +13,7 @@ import Data.Aeson (FromJSON(..), Value, json)
1313import Data.Aeson.Types (Parser)
1414import Data.Aeson.Parser (eitherDecodeWith)
1515import Data.Aeson.Internal (formatError, iparse)
16−import Data.Algorithm.Diff (Diff(..), getGroupedDiff)
16+import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff)
1717import Data.Proxy (Proxy(..))
1818import Data.Semigroup ((<>))
1919import Data.Sequence (Seq)
@@ -136,6 +136,29 @@ outputGeneric choice = concat
136136 , "[1,"
137137 ]
138138
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+
139162 , testWith "EitherTextInt"
140163 (select
141164 thEitherTextIntParseJSONUntaggedValue
@@ -196,3 +219,6 @@ testFor name _ = testWith name (parseJSON :: Value -> Parser a)
196219
197220testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output
198221testWithSomeType = testWith
222+
223+testWithFoo :: String -> (Value -> Parser Foo) -> [L.ByteString] -> Output
224+testWithFoo = testWith
tests/Instances.hs+1−4
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE FlexibleInstances #-}
43{-# LANGUAGE NoImplicitPrelude #-}
@@ -25,14 +24,12 @@ import qualified Data.HashMap.Strict as HM
2524
2625import Data.Orphans ()
2726import Test.QuickCheck.Instances ()
28−#if MIN_VERSION_base(4,7,0)
2927import Data.Hashable.Time ()
30−#endif
3128
3229-- "System" types.
3330
3431instance Arbitrary DotNetTime where
35− arbitrary = DotNetTime `liftM` arbitrary
32+ arbitrary = DotNetTime `fmap` arbitrary
3633 shrink = map DotNetTime . shrink . fromDotNetTime
3734
3835-- | Compare timezone part only on 'timeZoneMinutes'
tests/Options.hs+11
@@ -55,3 +55,14 @@ optsOptionField = optsDefault
5555 { fieldLabelModifier = const "field"
5656 , omitNothingFields = True
5757 }
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/PropertyGeneric.hs−8
@@ -44,11 +44,9 @@ genericTests =
4444 , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
4545 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
4646
47−#if __GLASGOW_HASKELL__ >= 706
4847 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)
4948 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)
5049 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)
51−#endif
5250 ]
5351 ]
5452 , testGroup "OneConstructor" [
@@ -85,30 +83,24 @@ genericTests =
8583
8684 , testProperty "SomeType2ElemArray" $
8785 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray
88−#if __GLASGOW_HASKELL__ >= 706
8986 , testProperty "SomeType2ElemArray unary" $
9087 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray
9188 , testProperty "SomeType2ElemArray unary agree" $
9289 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray
93−#endif
9490
9591 , testProperty "SomeTypeTaggedObject" $
9692 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject
97−#if __GLASGOW_HASKELL__ >= 706
9893 , testProperty "SomeTypeTaggedObject unary" $
9994 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject
10095 , testProperty "SomeTypeTaggedObject unary agree" $
10196 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject
102−#endif
10397
10498 , testProperty "SomeTypeObjectWithSingleField" $
10599 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField
106−#if __GLASGOW_HASKELL__ >= 706
107100 , testProperty "SomeTypeObjectWithSingleField unary" $
108101 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField
109102 , testProperty "SomeTypeObjectWithSingleField unary agree" $
110103 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField
111−#endif
112104
113105 , testProperty "SomeTypeOmitNothingFields" $
114106 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
tests/PropertyKeys.hs−3
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE NoImplicitPrelude #-}
32
43module PropertyKeys ( keysTests ) where
@@ -31,12 +30,10 @@ keysTests =
3130 , testProperty "Natural" $ roundTripKey (undefined :: Natural)
3231 , testProperty "Float" $ roundTripKey (undefined :: Float)
3332 , testProperty "Double" $ roundTripKey (undefined :: Double)
34−#if MIN_VERSION_base(4,7,0)
3533 , testProperty "Day" $ roundTripKey (undefined :: Day)
3634 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)
3735 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)
3836 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
39−#endif
4037 , testProperty "Version" $ roundTripKey (undefined :: Version)
4138 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)
4239 , testProperty "UUID" $ roundTripKey UUID.nil
tests/SerializationFormatSpec.hs−4
@@ -3,9 +3,7 @@
33{-# LANGUAGE GADTs #-}
44{-# LANGUAGE NoImplicitPrelude #-}
55{-# LANGUAGE OverloadedStrings #-}
6−#if __GLASGOW_HASKELL__ >= 708
76{-# LANGUAGE DataKinds #-}
8−#endif
97
108------------------------------------------------------------------------------
119-- These tests assert that the JSON serialization doesn't change by accident.
@@ -77,10 +75,8 @@ jsonExamples =
7775 , example "Just" "1" (Just 1 :: Maybe Int)
7876 , example "Proxy Int" "null" (Proxy :: Proxy Int)
7977 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)
80−#if __GLASGOW_HASKELL__ >= 708
8178 -- Test Tagged instance is polykinded
8279 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)
83−#endif
8480 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)
8581 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))
8682 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)
tests/Types.hs−2
@@ -119,9 +119,7 @@ deriving instance Generic (Sum4 a b c d)
119119deriving instance Generic (Approx a)
120120deriving instance Generic Nullary
121121deriving instance Generic (SomeType a)
122−#if __GLASGOW_HASKELL__ >= 706
123122deriving instance Generic1 SomeType
124−#endif
125123deriving instance Generic OptionField
126124deriving instance Generic EitherTextInt
127125
tests/UnitTests.hs+162−3
@@ -29,12 +29,19 @@ import Data.Aeson.Internal (JSONPathElement(..), formatError)
2929import Data.Aeson.QQ.Simple (aesonQQ)
3030import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
3131import Data.Aeson.Text (encodeToTextBuilder)
32−import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null, Object), camelTo, camelTo2, defaultOptions, omitNothingFields, parse)
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)
3340import Data.Char (toUpper)
3441import Data.Either.Compat (isLeft, isRight)
3542import Data.Hashable (hash)
3643import Data.HashMap.Strict (HashMap)
37−import Data.List (sort)
44+import Data.List (sort, isSuffixOf)
3845import Data.Maybe (fromMaybe)
3946import Data.Scientific (Scientific, scientific)
4047import Data.Tagged (Tagged(..))
@@ -47,16 +54,19 @@ import Numeric.Natural (Natural)
4754import System.Directory (getDirectoryContents)
4855import System.FilePath ((</>), takeExtension, takeFileName)
4956import Test.Tasty (TestTree, testGroup)
50−import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase)
57+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))
5158import Text.Printf (printf)
5259import UnitTests.NullaryConstructors (nullaryConstructors)
60+import qualified Data.ByteString as S
5361import qualified Data.ByteString.Base16.Lazy as LBase16
5462import qualified Data.ByteString.Lazy.Char8 as L
5563import qualified Data.HashSet as HashSet
64+import qualified Data.HashMap.Lazy as HashMap
5665import qualified Data.Text.Lazy as LT
5766import qualified Data.Text.Lazy.Builder as TLB
5867import qualified Data.Text.Lazy.Encoding as LT
5968import qualified Data.Text.Lazy.Encoding as TLE
69+import qualified Data.Vector as Vector
6070import qualified ErrorMessages
6171import qualified SerializationFormatSpec
6272
@@ -102,7 +112,12 @@ tests = testGroup "unit" [
102112 , testGroup "SingleMaybeField" singleMaybeField
103113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest
104114 , testCase "SingleFieldCon" singleFieldCon
115+ , testGroup "UnknownFields" unknownFields
116+ , testGroup "Ordering of object keys" keyOrdering
105117 , testCase "Ratio with denominator 0" ratioDenominator0
118+ , testCase "Rational parses number" rationalNumber
119+ , testCase "Big rational" bigRationalDecoding
120+ , testCase "Small rational" smallRationalDecoding
106121 , testCase "Big scientific exponent" bigScientificExponent
107122 , testCase "Big integer decoding" bigIntegerDecoding
108123 , testCase "Big natural decading" bigNaturalDecoding
@@ -243,6 +258,18 @@ formatErrorExample =
243258 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
244259 in assertEqual "formatError example" lhs rhs
245260
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+
246273------------------------------------------------------------------------------
247274-- Comparison (.:?) and (.:!)
248275------------------------------------------------------------------------------
@@ -513,6 +540,7 @@ showOptions =
513540 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
514541 ++ ", unwrapUnaryRecords = False"
515542 ++ ", tagSingleConstructors = False"
543+ ++ ", rejectUnknownFields = False"
516544 ++ "}")
517545 (show defaultOptions)
518546
@@ -557,12 +585,138 @@ singleFieldCon :: Assertion
557585singleFieldCon =
558586 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")
559587
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+
560695ratioDenominator0 :: Assertion
561696ratioDenominator0 =
562697 assertEqual "Ratio with denominator 0"
563698 (Left "Error in $: Ratio denominator was 0")
564699 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)
565700
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+
566720bigScientificExponent :: Assertion
567721bigScientificExponent =
568722 assertEqual "Encoding an integral scientific with a large exponent should normalize it"
@@ -599,3 +753,8 @@ deriveToJSON defaultOptions ''Foo
599753deriveToJSON1 defaultOptions ''Foo
600754
601755deriveJSON 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+5
@@ -14,6 +14,7 @@ import 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_)
1718import Data.Maybe (fromJust)
1819import Encoders
1920import Test.Tasty.HUnit ((@=?), Assertion)
@@ -52,6 +53,10 @@ nullaryConstructors =
5253 -- Make sure that the old `"contents" : []' is still allowed
5354 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")
5455 , 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
5560 ]
5661 where
5762 enc = eitherDecode . toLazyByteString . fromEncoding
tests/golden/generic.expected+11−3
@@ -6,11 +6,11 @@ Error in $: parsing Types.Nullary failed, expected one of the tags ["C1","C2","C
66Error in $: parsing Types.Nullary failed, expected String, but encountered Array
77SomeType (tagged)
88Error in $.contents: parsing Int failed, expected Number, but encountered Boolean
9−Error in $: parsing Types.SomeType(Unary) failed, key "contents" not present
10−Error in $: parsing Types.SomeType(Record) failed, key "testone" not present
9+Error in $: parsing Types.SomeType(Unary) failed, key "contents" not found
10+Error in $: parsing Types.SomeType(Record) failed, key "testone" not found
1111Error in $.testone: parsing Double failed, unexpected Boolean
1212Error 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, key "tag" not present
13+Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found
1414Error in $: parsing Types.SomeType failed, expected Object, but encountered Array
1515SomeType (single-field)
1616Error in $.unary: parsing Int failed, expected Number, but encountered Object
@@ -31,6 +31,14 @@ Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encou
3131Error in $: parsing Types.SomeType failed, expected Array, but encountered Object
3232Error in $: not enough input. Expecting ',' or ']'
3333Error 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"]
3442EitherTextInt
3543Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"
3644Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array
travis/cabal_macros.hnew file+448
@@ -0,0 +1,448 @@
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,6 +7,11 @@ 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+ ;;
1015 stack)
1116 stack --no-terminal --skip-ghc-check setup
1217 stack --no-terminal --skip-ghc-check test --only-snapshot
@@ -44,4 +49,10 @@ case $BUILD in
4449 cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
4550 fi
4651 ;;
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+ ;;
4758esac
travis/script.sh+4−2
@@ -19,9 +19,11 @@ 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+ ;;
2226 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
2527 make lint
2628 ;;
2729esac