@@ -5,6 +5,10 @@
5#if MIN_VERSION_ghc_prim(0,3,1)
5#if MIN_VERSION_ghc_prim(0,3,1)
6{-# LANGUAGE MagicHash #-}
6{-# LANGUAGE MagicHash #-}
8+#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706
9+-- Work around a compiler bug
10+{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}
9-- Module: Data.Aeson.Parser.Internal
13-- Module: Data.Aeson.Parser.Internal
10-- Copyright: (c) 2011-2016 Bryan O'Sullivan
14-- Copyright: (c) 2011-2016 Bryan O'Sullivan
@@ -21,30 +25,43 @@ module Data.Aeson.Parser.Internal
22 -- * Lazy parsers
26 -- * Lazy parsers
23 json, jsonEOF
27 json, jsonEOF
26 , jstring_
34 , jstring_
27 , scientific
35 , scientific
28 -- * Strict parsers
36 -- * Strict parsers
29 , json', jsonEOF'
37 , json', jsonEOF'
31 -- * Helpers
43 -- * Helpers
32 , decodeWith
44 , decodeWith
33 , decodeStrictWith
45 , decodeStrictWith
34 , eitherDecodeWith
46 , eitherDecodeWith
35 , eitherDecodeStrictWith
47 , eitherDecodeStrictWith
48+ -- ** Handling objects with duplicate keys
38import Prelude.Compat
53import Prelude.Compat
40import Control.Applicative ((<|>))
55import Control.Applicative ((<|>))
41import Control.Monad (void, when)
56import 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(..))
43import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
58import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
59+import Data.Function (fix)
44import Data.Functor.Compat (($>))
60import Data.Functor.Compat (($>))
45import Data.Scientific (Scientific)
61import Data.Scientific (Scientific)
46import Data.Text (Text)
62import Data.Text (Text)
63+import Data.Vector (Vector)
47−import Data.Vector as Vector (Vector, empty, fromListN, reverse)
64+import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
48import qualified Data.Attoparsec.ByteString as A
65import qualified Data.Attoparsec.ByteString as A
49import qualified Data.Attoparsec.Lazy as L
66import qualified Data.Attoparsec.Lazy as L
50import qualified Data.ByteString as B
67import qualified Data.ByteString as B
@@ -76,7 +93,7 @@ import qualified Data.Text.Encoding as TE
76#define C_n 110
93#define C_n 110
77#define C_t 116
94#define C_t 116
79−-- | Parse a top-level JSON value.
96+-- | Parse any JSON value.
81-- The conversion of a parsed value to a Haskell value is deferred
98-- The conversion of a parsed value to a Haskell value is deferred
82-- until the Haskell value is needed. This may improve performance if
99-- until the Haskell value is needed. This may improve performance if
@@ -86,10 +103,15 @@ import qualified Data.Text.Encoding as TE
86-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
103-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
87-- parsed only object or array types, in conformance with the
104-- parsed only object or array types, in conformance with the
88-- now-obsolete RFC 4627.
105-- now-obsolete RFC 4627.
109+-- If an object contains duplicate keys, only the first one will be kept.
110+-- For a more flexible alternative, see 'jsonWith'.
89json :: Parser Value
111json :: Parser Value
90json = value
112json = value
92−-- | Parse a top-level JSON value.
114+-- | Parse any JSON value.
94-- This is a strict version of 'json' which avoids building up thunks
116-- This is a strict version of 'json' which avoids building up thunks
95-- during parsing; it performs all conversions immediately. Prefer
117-- during parsing; it performs all conversions immediately. Prefer
@@ -98,23 +120,38 @@ json = value
98-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
120-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
99-- parsed only object or array types, in conformance with the
121-- parsed only object or array types, in conformance with the
100-- now-obsolete RFC 4627.
122-- now-obsolete RFC 4627.
126+-- If an object contains duplicate keys, only the first one will be kept.
127+-- For a more flexible alternative, see 'jsonWith''.
101json' :: Parser Value
128json' :: Parser Value
102json' = value'
129json' = 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+-- hFromList outside of the recursive loop for proper inlining.
104−object_ :: Parser Value
135+object_ :: HFromList -> Parser Value -> Parser Value
105−object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
136+object_ hFromList val = {-# SCC "object_" #-} Object <$> objectValues hFromList jstring val
137+{-# INLINE object_ #-}
107−object_' :: Parser Value
139+object_' :: HFromList -> Parser Value -> Parser Value
108−object_' = {-# SCC "object_'" #-} do
140+object_' hFromList val' = {-# SCC "object_'" #-} do
109− !vals <- objectValues jstring' value'
141+ !vals <- objectValues hFromList jstring' val'
110 return (Object vals)
142 return (Object vals)
112 jstring' = do
144 jstring' = do
113 !s <- jstring
145 !s <- jstring
147+{-# INLINE object_' #-}
149+-- The object parser 'objectValues' is parameterized by the object constructor.
150+-- See also 'jsonWith'.
151+type HFromList = [(Text, Value)] -> Parser Object
116−objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
153+objectValues :: HFromList -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
117−objectValues str val = do
154+objectValues hFromList str val = do
118 skipSpace
155 skipSpace
119 w <- A.peekWord8'
156 w <- A.peekWord8'
120 if w == CLOSE_CURLY
157 if w == CLOSE_CURLY
@@ -130,16 +167,18 @@ objectValues str val = do
130 let acc' = (k, v) : acc
167 let acc' = (k, v) : acc
131 if ch == COMMA
168 if ch == COMMA
132 then skipSpace >> loop acc'
169 then skipSpace >> loop acc'
133− else return (H.fromList acc')
170+ else hFromList acc'
134{-# INLINE objectValues #-}
171{-# INLINE objectValues #-}
136−array_ :: Parser Value
173+array_ :: Parser Value -> Parser Value
137−array_ = {-# SCC "array_" #-} Array <$> arrayValues value
174+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
175+{-# INLINE array_ #-}
139−array_' :: Parser Value
177+array_' :: Parser Value -> Parser Value
140−array_' = {-# SCC "array_'" #-} do
178+array_' val = {-# SCC "array_'" #-} do
141− !vals <- arrayValues value'
179+ !vals <- arrayValues val
142 return (Array vals)
180 return (Array vals)
181+{-# INLINE array_' #-}
144arrayValues :: Parser Value -> Parser (Vector Value)
183arrayValues :: Parser Value -> Parser (Vector Value)
145arrayValues val = do
184arrayValues val = do
@@ -157,42 +196,104 @@ arrayValues val = do
157 else return (Vector.reverse (Vector.fromListN len (v:acc)))
196 else return (Vector.reverse (Vector.fromListN len (v:acc)))
158{-# INLINE arrayValues #-}
197{-# INLINE arrayValues #-}
160−-- | Parse any JSON value. You should usually 'json' in preference to
199+-- | Parse any JSON value. Synonym of 'json'.
161−-- this function, as this function relaxes the object-or-array
162−-- requirement of RFC 4627.
164−-- In particular, be careful in using this function if you think your
165−-- code might interoperate with Javascript. A naï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.
170value :: Parser Value
200value :: Parser Value
171−value = do
201+value = jsonWith (pure . H.fromList)
203+-- | Parse any JSON value.
205+-- This parser is parameterized by a function to construct an 'Object'
206+-- from a raw list of key-value pairs, where duplicates are preserved.
207+-- The pairs appear in __reverse order__ from the source.
211+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
214+-- 'json' = 'jsonWith' ('pure' '.' 'H.fromList')
217+-- 'jsonLast' keeps the last occurence of each key, using
218+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
221+-- 'jsonLast' = 'jsonWith' ('pure' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
224+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
228+-- 'jsonAccum' = 'jsonWith' ('pure' . 'fromListAccum')
231+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
234+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
236+jsonWith :: ([(Text, Value)] -> Parser Object) -> Parser Value
237+jsonWith hFromList = fix $ \value_ -> do
172 skipSpace
238 skipSpace
173 w <- A.peekWord8'
239 w <- A.peekWord8'
174 case w of
240 case w of
175 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
241 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
176− OPEN_CURLY -> A.anyWord8 *> object_
242+ OPEN_CURLY -> A.anyWord8 *> object_ hFromList value_
177− OPEN_SQUARE -> A.anyWord8 *> array_
243+ OPEN_SQUARE -> A.anyWord8 *> array_ value_
178 C_f -> string "false" $> Bool False
244 C_f -> string "false" $> Bool False
179 C_t -> string "true" $> Bool True
245 C_t -> string "true" $> Bool True
180 C_n -> string "null" $> Null
246 C_n -> string "null" $> Null
181 _ | w >= 48 && w <= 57 || w == 45
247 _ | w >= 48 && w <= 57 || w == 45
182 -> Number <$> scientific
248 -> Number <$> scientific
183 | otherwise -> fail "not a valid json value"
249 | otherwise -> fail "not a valid json value"
250+{-# INLINE jsonWith #-}
252+-- | Variant of 'json' which keeps only the last occurence of every key.
253+jsonLast :: Parser Value
254+jsonLast = jsonWith (pure . H.fromListWith (const id))
256+-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
257+-- key-value pairs with the same keys.
258+jsonAccum :: Parser Value
259+jsonAccum = jsonWith (pure . fromListAccum)
261+-- | Variant of 'json' which fails if any object contains duplicate keys.
262+jsonNoDup :: Parser Value
263+jsonNoDup = jsonWith parseListNoDup
265+-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
266+-- associated values from the original list @kvs@.
268+-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]
269+-- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]
270+fromListAccum :: [(Text, Value)] -> Object
272+ fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)
274+-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
275+parseListNoDup :: [(Text, Value)] -> Parser Object
277+ H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
279+ unwrap k Nothing = fail $ "found duplicate key: " ++ show k
280+ unwrap _ (Just v) = pure v
185−-- | Strict version of 'value'. See also 'json''.
282+-- | Strict version of 'value'. Synonym of 'json''.
186value' :: Parser Value
283value' :: Parser Value
187−value' = do
284+value' = jsonWith' (pure . H.fromList)
286+-- | Strict version of 'jsonWith'.
287+jsonWith' :: ([(Text, Value)] -> Parser Object) -> Parser Value
288+jsonWith' hFromList = fix $ \value_ -> do
188 skipSpace
289 skipSpace
189 w <- A.peekWord8'
290 w <- A.peekWord8'
190 case w of
291 case w of
191 DOUBLE_QUOTE -> do
292 DOUBLE_QUOTE -> do
192 !s <- A.anyWord8 *> jstring_
293 !s <- A.anyWord8 *> jstring_
193 return (String s)
294 return (String s)
194− OPEN_CURLY -> A.anyWord8 *> object_'
295+ OPEN_CURLY -> A.anyWord8 *> object_' hFromList value_
195− OPEN_SQUARE -> A.anyWord8 *> array_'
296+ OPEN_SQUARE -> A.anyWord8 *> array_' value_
196 C_f -> string "false" $> Bool False
297 C_f -> string "false" $> Bool False
197 C_t -> string "true" $> Bool True
298 C_t -> string "true" $> Bool True
198 C_n -> string "null" $> Null
299 C_n -> string "null" $> Null
@@ -201,6 +302,20 @@ value' = do
201 !n <- scientific
302 !n <- scientific
202 return (Number n)
303 return (Number n)
203 | otherwise -> fail "not a valid json value"
304 | otherwise -> fail "not a valid json value"
305+{-# INLINE jsonWith' #-}
307+-- | Variant of 'json'' which keeps only the last occurence of every key.
308+jsonLast' :: Parser Value
309+jsonLast' = jsonWith' (pure . H.fromListWith (const id))
311+-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve
312+-- key-value pairs with the same keys.
313+jsonAccum' :: Parser Value
314+jsonAccum' = jsonWith' (pure . fromListAccum)
316+-- | Variant of 'json'' which fails if any object contains duplicate keys.
317+jsonNoDup' :: Parser Value
318+jsonNoDup' = jsonWith' parseListNoDup
205-- | Parse a quoted JSON string.
320-- | Parse a quoted JSON string.
206jstring :: Parser Text
321jstring :: Parser Text