@@ -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,38 @@ 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+-- hFromList outside of the recursive loop for proper inlining.
134+
135+object_ :: HFromList -> Parser Value -> Parser Value
136+object_ hFromList val = {-# SCC "object_" #-} Object <$> objectValues hFromList jstring val
137+{-# INLINE object_ #-}
106138
107−object_' :: Parser Value
108−object_' = {-# SCC "object_'" #-} do
109− !vals <- objectValues jstring' value'
139+object_' :: HFromList -> Parser Value -> Parser Value
140+object_' hFromList val' = {-# SCC "object_'" #-} do
141+ !vals <- objectValues hFromList 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+-- The object parser 'objectValues' is parameterized by the object constructor.
150+-- See also 'jsonWith'.
151+type HFromList = [(Text, Value)] -> Parser Object
152+
153+objectValues :: HFromList -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
154+objectValues hFromList str val = do
118155 skipSpace
119156 w <- A.peekWord8'
120157 if w == CLOSE_CURLY
@@ -130,16 +167,18 @@ objectValues str val = do
130167 let acc' = (k, v) : acc
131168 if ch == COMMA
132169 then skipSpace >> loop acc'
133− else return (H.fromList acc')
170+ else hFromList acc'
134171{-# INLINE objectValues #-}
135172
136−array_ :: Parser Value
137−array_ = {-# SCC "array_" #-} Array <$> arrayValues value
173+array_ :: Parser Value -> Parser Value
174+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
175+{-# INLINE array_ #-}
138176
139−array_' :: Parser Value
140−array_' = {-# SCC "array_'" #-} do
141− !vals <- arrayValues value'
177+array_' :: Parser Value -> Parser Value
178+array_' val = {-# SCC "array_'" #-} do
179+ !vals <- arrayValues val
142180 return (Array vals)
181+{-# INLINE array_' #-}
143182
144183arrayValues :: Parser Value -> Parser (Vector Value)
145184arrayValues val = do
@@ -157,42 +196,104 @@ arrayValues val = do
157196 else return (Vector.reverse (Vector.fromListN len (v:acc)))
158197{-# INLINE arrayValues #-}
159198
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.
199+-- | Parse any JSON value. Synonym of 'json'.
170200value :: Parser Value
171−value = do
201+value = jsonWith (pure . H.fromList)
202+
203+-- | Parse any JSON value.
204+--
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.
208+--
209+-- ==== __Examples__
210+--
211+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
212+--
213+-- @
214+-- 'json' = 'jsonWith' ('pure' '.' 'H.fromList')
215+-- @
216+--
217+-- 'jsonLast' keeps the last occurence of each key, using
218+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
219+--
220+-- @
221+-- 'jsonLast' = 'jsonWith' ('pure' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
222+-- @
223+--
224+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
225+-- 'fromListAccum'.
226+--
227+-- @
228+-- 'jsonAccum' = 'jsonWith' ('pure' . 'fromListAccum')
229+-- @
230+--
231+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
232+--
233+-- @
234+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
235+-- @
236+jsonWith :: ([(Text, Value)] -> Parser Object) -> Parser Value
237+jsonWith hFromList = fix $ \value_ -> do
172238 skipSpace
173239 w <- A.peekWord8'
174240 case w of
175241 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
176− OPEN_CURLY -> A.anyWord8 *> object_
177− OPEN_SQUARE -> A.anyWord8 *> array_
242+ OPEN_CURLY -> A.anyWord8 *> object_ hFromList value_
243+ OPEN_SQUARE -> A.anyWord8 *> array_ value_
178244 C_f -> string "false" $> Bool False
179245 C_t -> string "true" $> Bool True
180246 C_n -> string "null" $> Null
181247 _ | w >= 48 && w <= 57 || w == 45
182248 -> Number <$> scientific
183249 | otherwise -> fail "not a valid json value"
250+{-# INLINE jsonWith #-}
251+
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))
255+
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)
260+
261+-- | Variant of 'json' which fails if any object contains duplicate keys.
262+jsonNoDup :: Parser Value
263+jsonNoDup = jsonWith parseListNoDup
184264
185−-- | Strict version of 'value'. See also 'json''.
265+-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
266+-- associated values from the original list @kvs@.
267+--
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
271+fromListAccum =
272+ fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)
273+
274+-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
275+parseListNoDup :: [(Text, Value)] -> Parser Object
276+parseListNoDup =
277+ H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
278+ where
279+ unwrap k Nothing = fail $ "found duplicate key: " ++ show k
280+ unwrap _ (Just v) = pure v
281+
282+-- | Strict version of 'value'. Synonym of 'json''.
186283value' :: Parser Value
187−value' = do
284+value' = jsonWith' (pure . H.fromList)
285+
286+-- | Strict version of 'jsonWith'.
287+jsonWith' :: ([(Text, Value)] -> Parser Object) -> Parser Value
288+jsonWith' hFromList = fix $ \value_ -> do
188289 skipSpace
189290 w <- A.peekWord8'
190291 case w of
191292 DOUBLE_QUOTE -> do
192293 !s <- A.anyWord8 *> jstring_
193294 return (String s)
194− OPEN_CURLY -> A.anyWord8 *> object_'
195− OPEN_SQUARE -> A.anyWord8 *> array_'
295+ OPEN_CURLY -> A.anyWord8 *> object_' hFromList value_
296+ OPEN_SQUARE -> A.anyWord8 *> array_' value_
196297 C_f -> string "false" $> Bool False
197298 C_t -> string "true" $> Bool True
198299 C_n -> string "null" $> Null
@@ -201,6 +302,20 @@ value' = do
201302 !n <- scientific
202303 return (Number n)
203304 | otherwise -> fail "not a valid json value"
305+{-# INLINE jsonWith' #-}
306+
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))
310+
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)
315+
316+-- | Variant of 'json'' which fails if any object contains duplicate keys.
317+jsonNoDup' :: Parser Value
318+jsonNoDup' = jsonWith' parseListNoDup
204319
205320-- | Parse a quoted JSON string.
206321jstring :: Parser Text