@@ -21,30 +21,43 @@ module Data.Aeson.Parser.Internal
2121 (
2222 -- * Lazy parsers
2323 json, jsonEOF
24+ , jsonWith
25+ , jsonLast
26+ , jsonAccum
27+ , jsonNoDup
2428 , value
2529 , jstring
2630 , jstring_
2731 , scientific
2832 -- * Strict parsers
2933 , json', jsonEOF'
34+ , jsonWith'
35+ , jsonLast'
36+ , jsonAccum'
37+ , jsonNoDup'
3038 , value'
3139 -- * Helpers
3240 , decodeWith
3341 , decodeStrictWith
3442 , eitherDecodeWith
3543 , eitherDecodeStrictWith
44+ -- ** Handling objects with duplicate keys
45+ , fromListAccum
46+ , parseListNoDup
3647 ) where
3748
3849import Prelude.Compat
3950
4051import Control.Applicative ((<|>))
4152import 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(..))
4354import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
55+import Data.Function (fix)
4456import Data.Functor.Compat (($>))
4557import Data.Scientific (Scientific)
4658import Data.Text (Text)
47−import Data.Vector as Vector (Vector, empty, fromListN, reverse)
59+import Data.Vector (Vector)
60+import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)
4861import qualified Data.Attoparsec.ByteString as A
4962import qualified Data.Attoparsec.Lazy as L
5063import qualified Data.ByteString as B
@@ -76,7 +89,7 @@ import qualified Data.Text.Encoding as TE
7689#define C_n 110
7790#define C_t 116
7891
79−-- | Parse a top-level JSON value.
92+-- | Parse any JSON value.
8093--
8194-- The conversion of a parsed value to a Haskell value is deferred
8295-- until the Haskell value is needed. This may improve performance if
@@ -86,10 +99,15 @@ import qualified Data.Text.Encoding as TE
8699-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
87100-- parsed only object or array types, in conformance with the
88101-- now-obsolete RFC 4627.
102+--
103+-- ==== Warning
104+--
105+-- If an object contains duplicate keys, only the first one will be kept.
106+-- For a more flexible alternative, see 'jsonWith'.
89107json :: Parser Value
90108json = value
91109
92−-- | Parse a top-level JSON value.
110+-- | Parse any JSON value.
93111--
94112-- This is a strict version of 'json' which avoids building up thunks
95113-- during parsing; it performs all conversions immediately. Prefer
@@ -98,23 +116,38 @@ json = value
98116-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
99117-- parsed only object or array types, in conformance with the
100118-- now-obsolete RFC 4627.
119+--
120+-- ==== Warning
121+--
122+-- If an object contains duplicate keys, only the first one will be kept.
123+-- For a more flexible alternative, see 'jsonWith''.
101124json' :: Parser Value
102125json' = value'
103126
104−object_ :: Parser Value
105−object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
127+-- Open recursion: object_, object_', array_, array_' are parameterized by the
128+-- toplevel Value parser to be called recursively, to keep the parameter
129+-- hFromList outside of the recursive loop for proper inlining.
106130
107−object_' :: Parser Value
108−object_' = {-# SCC "object_'" #-} do
109− !vals <- objectValues jstring' value'
131+object_ :: HFromList -> Parser Value -> Parser Value
132+object_ hFromList val = {-# SCC "object_" #-} Object <$> objectValues hFromList jstring val
133+{-# INLINE object_ #-}
134+
135+object_' :: HFromList -> Parser Value -> Parser Value
136+object_' hFromList val' = {-# SCC "object_'" #-} do
137+ !vals <- objectValues hFromList jstring' val'
110138 return (Object vals)
111139 where
112140 jstring' = do
113141 !s <- jstring
114142 return s
143+{-# INLINE object_' #-}
144+
145+-- The object parser 'objectValues' is parameterized by the object constructor.
146+-- See also 'jsonWith'.
147+type HFromList = [(Text, Value)] -> Parser Object
115148
116−objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
117−objectValues str val = do
149+objectValues :: HFromList -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
150+objectValues hFromList str val = do
118151 skipSpace
119152 w <- A.peekWord8'
120153 if w == CLOSE_CURLY
@@ -130,16 +163,18 @@ objectValues str val = do
130163 let acc' = (k, v) : acc
131164 if ch == COMMA
132165 then skipSpace >> loop acc'
133− else return (H.fromList acc')
166+ else hFromList acc'
134167{-# INLINE objectValues #-}
135168
136−array_ :: Parser Value
137−array_ = {-# SCC "array_" #-} Array <$> arrayValues value
169+array_ :: Parser Value -> Parser Value
170+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
171+{-# INLINE array_ #-}
138172
139−array_' :: Parser Value
140−array_' = {-# SCC "array_'" #-} do
141− !vals <- arrayValues value'
173+array_' :: Parser Value -> Parser Value
174+array_' val = {-# SCC "array_'" #-} do
175+ !vals <- arrayValues val
142176 return (Array vals)
177+{-# INLINE array_' #-}
143178
144179arrayValues :: Parser Value -> Parser (Vector Value)
145180arrayValues val = do
@@ -157,42 +192,104 @@ arrayValues val = do
157192 else return (Vector.reverse (Vector.fromListN len (v:acc)))
158193{-# INLINE arrayValues #-}
159194
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ï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.
195+-- | Parse any JSON value. Synonym of 'json'.
170196value :: Parser Value
171−value = do
197+value = jsonWith (pure . H.fromList)
198+
199+-- | Parse any JSON value.
200+--
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.
204+--
205+-- ==== __Examples__
206+--
207+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
208+--
209+-- @
210+-- 'json' = 'jsonWith' ('pure' '.' 'H.fromList')
211+-- @
212+--
213+-- 'jsonLast' keeps the last occurence of each key, using
214+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
215+--
216+-- @
217+-- 'jsonLast' = 'jsonWith' ('pure' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
218+-- @
219+--
220+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
221+-- 'fromListAccum'.
222+--
223+-- @
224+-- 'jsonAccum' = 'jsonWith' ('pure' . 'fromListAccum')
225+-- @
226+--
227+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
228+--
229+-- @
230+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
231+-- @
232+jsonWith :: ([(Text, Value)] -> Parser Object) -> Parser Value
233+jsonWith hFromList = fix $ \value_ -> do
172234 skipSpace
173235 w <- A.peekWord8'
174236 case w of
175237 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
176− OPEN_CURLY -> A.anyWord8 *> object_
177− OPEN_SQUARE -> A.anyWord8 *> array_
238+ OPEN_CURLY -> A.anyWord8 *> object_ hFromList value_
239+ OPEN_SQUARE -> A.anyWord8 *> array_ value_
178240 C_f -> string "false" $> Bool False
179241 C_t -> string "true" $> Bool True
180242 C_n -> string "null" $> Null
181243 _ | w >= 48 && w <= 57 || w == 45
182244 -> Number <$> scientific
183245 | otherwise -> fail "not a valid json value"
246+{-# INLINE jsonWith #-}
247+
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))
251+
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)
256+
257+-- | Variant of 'json' which fails if any object contains duplicate keys.
258+jsonNoDup :: Parser Value
259+jsonNoDup = jsonWith parseListNoDup
184260
185−-- | Strict version of 'value'. See also 'json''.
261+-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
262+-- associated values from the original list @kvs@.
263+--
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
267+fromListAccum =
268+ fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)
269+
270+-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
271+parseListNoDup :: [(Text, Value)] -> Parser Object
272+parseListNoDup =
273+ H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
274+ where
275+ unwrap k Nothing = fail $ "found duplicate key: " ++ show k
276+ unwrap _ (Just v) = pure v
277+
278+-- | Strict version of 'value'. Synonym of 'json''.
186279value' :: Parser Value
187−value' = do
280+value' = jsonWith' (pure . H.fromList)
281+
282+-- | Strict version of 'jsonWith'.
283+jsonWith' :: ([(Text, Value)] -> Parser Object) -> Parser Value
284+jsonWith' hFromList = fix $ \value_ -> do
188285 skipSpace
189286 w <- A.peekWord8'
190287 case w of
191288 DOUBLE_QUOTE -> do
192289 !s <- A.anyWord8 *> jstring_
193290 return (String s)
194− OPEN_CURLY -> A.anyWord8 *> object_'
195− OPEN_SQUARE -> A.anyWord8 *> array_'
291+ OPEN_CURLY -> A.anyWord8 *> object_' hFromList value_
292+ OPEN_SQUARE -> A.anyWord8 *> array_' value_
196293 C_f -> string "false" $> Bool False
197294 C_t -> string "true" $> Bool True
198295 C_n -> string "null" $> Null
@@ -201,6 +298,20 @@ value' = do
201298 !n <- scientific
202299 return (Number n)
203300 | otherwise -> fail "not a valid json value"
301+{-# INLINE jsonWith' #-}
302+
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))
306+
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)
311+
312+-- | Variant of 'json'' which fails if any object contains duplicate keys.
313+jsonNoDup' :: Parser Value
314+jsonNoDup' = jsonWith' parseListNoDup
204315
205316-- | Parse a quoted JSON string.
206317jstring :: Parser Text