@@ -21,30 +21,43 @@ module Data.Aeson.Parser.Internal
22 -- * Lazy parsers
22 -- * Lazy parsers
23 json, jsonEOF
23 json, jsonEOF
26 , jstring_
30 , jstring_
27 , scientific
31 , scientific
28 -- * Strict parsers
32 -- * Strict parsers
29 , json', jsonEOF'
33 , json', jsonEOF'
31 -- * Helpers
39 -- * Helpers
32 , decodeWith
40 , decodeWith
33 , decodeStrictWith
41 , decodeStrictWith
34 , eitherDecodeWith
42 , eitherDecodeWith
35 , eitherDecodeStrictWith
43 , eitherDecodeStrictWith
44+ -- ** Handling objects with duplicate keys
38import Prelude.Compat
49import Prelude.Compat
40import Control.Applicative ((<|>))
51import Control.Applicative ((<|>))
41import Control.Monad (void, when)
52import Control.Monad (void, when)
42−import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
53+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))
43import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
54import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
55+import Data.Function (fix)
44import Data.Functor.Compat (($>))
56import Data.Functor.Compat (($>))
45import Data.Scientific (Scientific)
57import Data.Scientific (Scientific)
46import Data.Text (Text)
58import Data.Text (Text)
59+import Data.Vector (Vector)
47−import Data.Vector as Vector (Vector, empty, fromListN, reverse)
60+import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
48import qualified Data.Attoparsec.ByteString as A
61import qualified Data.Attoparsec.ByteString as A
49import qualified Data.Attoparsec.Lazy as L
62import qualified Data.Attoparsec.Lazy as L
50import qualified Data.ByteString as B
63import qualified Data.ByteString as B
@@ -76,7 +89,7 @@ import qualified Data.Text.Encoding as TE
76#define C_n 110
89#define C_n 110
77#define C_t 116
90#define C_t 116
79−-- | Parse a top-level JSON value.
92+-- | Parse any JSON value.
81-- The conversion of a parsed value to a Haskell value is deferred
94-- The conversion of a parsed value to a Haskell value is deferred
82-- until the Haskell value is needed. This may improve performance if
95-- until the Haskell value is needed. This may improve performance if
@@ -86,10 +99,15 @@ import qualified Data.Text.Encoding as TE
86-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
99-- 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
100-- parsed only object or array types, in conformance with the
88-- now-obsolete RFC 4627.
101-- now-obsolete RFC 4627.
105+-- If an object contains duplicate keys, only the first one will be kept.
106+-- For a more flexible alternative, see 'jsonWith'.
89json :: Parser Value
107json :: Parser Value
90json = value
108json = value
92−-- | Parse a top-level JSON value.
110+-- | Parse any JSON value.
94-- This is a strict version of 'json' which avoids building up thunks
112-- This is a strict version of 'json' which avoids building up thunks
95-- during parsing; it performs all conversions immediately. Prefer
113-- during parsing; it performs all conversions immediately. Prefer
@@ -98,23 +116,38 @@ json = value
98-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
116-- 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
117-- parsed only object or array types, in conformance with the
100-- now-obsolete RFC 4627.
118-- now-obsolete RFC 4627.
122+-- If an object contains duplicate keys, only the first one will be kept.
123+-- For a more flexible alternative, see 'jsonWith''.
101json' :: Parser Value
124json' :: Parser Value
102json' = value'
125json' = value'
104−object_ :: Parser Value
127+-- Open recursion: object_, object_', array_, array_' are parameterized by the
105−object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
128+-- toplevel Value parser to be called recursively, to keep the parameter
129+-- hFromList outside of the recursive loop for proper inlining.
107−object_' :: Parser Value
131+object_ :: HFromList -> Parser Value -> Parser Value
132+object_ hFromList val = {-# SCC "object_" #-} Object <$> objectValues hFromList jstring val
133+{-# INLINE object_ #-}
135+object_' :: HFromList -> Parser Value -> Parser Value
108−object_' = {-# SCC "object_'" #-} do
136+object_' hFromList val' = {-# SCC "object_'" #-} do
109− !vals <- objectValues jstring' value'
137+ !vals <- objectValues hFromList jstring' val'
110 return (Object vals)
138 return (Object vals)
112 jstring' = do
140 jstring' = do
113 !s <- jstring
141 !s <- jstring
143+{-# INLINE object_' #-}
145+-- The object parser 'objectValues' is parameterized by the object constructor.
146+-- See also 'jsonWith'.
147+type HFromList = [(Text, Value)] -> Parser Object
116−objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
149+objectValues :: HFromList -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
117−objectValues str val = do
150+objectValues hFromList str val = do
118 skipSpace
151 skipSpace
119 w <- A.peekWord8'
152 w <- A.peekWord8'
120 if w == CLOSE_CURLY
153 if w == CLOSE_CURLY
@@ -130,16 +163,18 @@ objectValues str val = do
130 let acc' = (k, v) : acc
163 let acc' = (k, v) : acc
131 if ch == COMMA
164 if ch == COMMA
132 then skipSpace >> loop acc'
165 then skipSpace >> loop acc'
133− else return (H.fromList acc')
166+ else hFromList acc'
134{-# INLINE objectValues #-}
167{-# INLINE objectValues #-}
136−array_ :: Parser Value
169+array_ :: Parser Value -> Parser Value
137−array_ = {-# SCC "array_" #-} Array <$> arrayValues value
170+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
171+{-# INLINE array_ #-}
139−array_' :: Parser Value
173+array_' :: Parser Value -> Parser Value
140−array_' = {-# SCC "array_'" #-} do
174+array_' val = {-# SCC "array_'" #-} do
141− !vals <- arrayValues value'
175+ !vals <- arrayValues val
142 return (Array vals)
176 return (Array vals)
177+{-# INLINE array_' #-}
144arrayValues :: Parser Value -> Parser (Vector Value)
179arrayValues :: Parser Value -> Parser (Vector Value)
145arrayValues val = do
180arrayValues val = do
@@ -157,42 +192,104 @@ arrayValues val = do
157 else return (Vector.reverse (Vector.fromListN len (v:acc)))
192 else return (Vector.reverse (Vector.fromListN len (v:acc)))
158{-# INLINE arrayValues #-}
193{-# INLINE arrayValues #-}
160−-- | Parse any JSON value. You should usually 'json' in preference to
195+-- | 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
196value :: Parser Value
171−value = do
197+value = jsonWith (pure . H.fromList)
199+-- | Parse any JSON value.
201+-- This parser is parameterized by a function to construct an 'Object'
202+-- from a raw list of key-value pairs, where duplicates are preserved.
203+-- The pairs appear in __reverse order__ from the source.
207+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
210+-- 'json' = 'jsonWith' ('pure' '.' 'H.fromList')
213+-- 'jsonLast' keeps the last occurence of each key, using
214+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
217+-- 'jsonLast' = 'jsonWith' ('pure' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
220+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
224+-- 'jsonAccum' = 'jsonWith' ('pure' . 'fromListAccum')
227+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
230+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
232+jsonWith :: ([(Text, Value)] -> Parser Object) -> Parser Value
233+jsonWith hFromList = fix $ \value_ -> do
172 skipSpace
234 skipSpace
173 w <- A.peekWord8'
235 w <- A.peekWord8'
174 case w of
236 case w of
175 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
237 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
176− OPEN_CURLY -> A.anyWord8 *> object_
238+ OPEN_CURLY -> A.anyWord8 *> object_ hFromList value_
177− OPEN_SQUARE -> A.anyWord8 *> array_
239+ OPEN_SQUARE -> A.anyWord8 *> array_ value_
178 C_f -> string "false" $> Bool False
240 C_f -> string "false" $> Bool False
179 C_t -> string "true" $> Bool True
241 C_t -> string "true" $> Bool True
180 C_n -> string "null" $> Null
242 C_n -> string "null" $> Null
181 _ | w >= 48 && w <= 57 || w == 45
243 _ | w >= 48 && w <= 57 || w == 45
182 -> Number <$> scientific
244 -> Number <$> scientific
183 | otherwise -> fail "not a valid json value"
245 | otherwise -> fail "not a valid json value"
246+{-# INLINE jsonWith #-}
248+-- | Variant of 'json' which keeps only the last occurence of every key.
249+jsonLast :: Parser Value
250+jsonLast = jsonWith (pure . H.fromListWith (const id))
252+-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
253+-- key-value pairs with the same keys.
254+jsonAccum :: Parser Value
255+jsonAccum = jsonWith (pure . fromListAccum)
257+-- | Variant of 'json' which fails if any object contains duplicate keys.
258+jsonNoDup :: Parser Value
259+jsonNoDup = jsonWith parseListNoDup
261+-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
262+-- associated values from the original list @kvs@.
264+-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]
265+-- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]
266+fromListAccum :: [(Text, Value)] -> Object
268+ fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)
270+-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
271+parseListNoDup :: [(Text, Value)] -> Parser Object
273+ H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
275+ unwrap k Nothing = fail $ "found duplicate key: " ++ show k
276+ unwrap _ (Just v) = pure v
185−-- | Strict version of 'value'. See also 'json''.
278+-- | Strict version of 'value'. Synonym of 'json''.
186value' :: Parser Value
279value' :: Parser Value
187−value' = do
280+value' = jsonWith' (pure . H.fromList)
282+-- | Strict version of 'jsonWith'.
283+jsonWith' :: ([(Text, Value)] -> Parser Object) -> Parser Value
284+jsonWith' hFromList = fix $ \value_ -> do
188 skipSpace
285 skipSpace
189 w <- A.peekWord8'
286 w <- A.peekWord8'
190 case w of
287 case w of
191 DOUBLE_QUOTE -> do
288 DOUBLE_QUOTE -> do
192 !s <- A.anyWord8 *> jstring_
289 !s <- A.anyWord8 *> jstring_
193 return (String s)
290 return (String s)
194− OPEN_CURLY -> A.anyWord8 *> object_'
291+ OPEN_CURLY -> A.anyWord8 *> object_' hFromList value_
195− OPEN_SQUARE -> A.anyWord8 *> array_'
292+ OPEN_SQUARE -> A.anyWord8 *> array_' value_
196 C_f -> string "false" $> Bool False
293 C_f -> string "false" $> Bool False
197 C_t -> string "true" $> Bool True
294 C_t -> string "true" $> Bool True
198 C_n -> string "null" $> Null
295 C_n -> string "null" $> Null
@@ -201,6 +298,20 @@ value' = do
201 !n <- scientific
298 !n <- scientific
202 return (Number n)
299 return (Number n)
203 | otherwise -> fail "not a valid json value"
300 | otherwise -> fail "not a valid json value"
301+{-# INLINE jsonWith' #-}
303+-- | Variant of 'json'' which keeps only the last occurence of every key.
304+jsonLast' :: Parser Value
305+jsonLast' = jsonWith' (pure . H.fromListWith (const id))
307+-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve
308+-- key-value pairs with the same keys.
309+jsonAccum' :: Parser Value
310+jsonAccum' = jsonWith' (pure . fromListAccum)
312+-- | Variant of 'json'' which fails if any object contains duplicate keys.
313+jsonNoDup' :: Parser Value
314+jsonNoDup' = jsonWith' parseListNoDup
205-- | Parse a quoted JSON string.
316-- | Parse a quoted JSON string.
206jstring :: Parser Text
317jstring :: Parser Text