@@ -0,0 +1,408 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE NoImplicitPrelude #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+-- |
6+-- Module: Data.Aeson.Scanner.Internal
7+-- Copyright: (c) 2011-2016 Bryan O'Sullivan
8+-- (c) 2011 MailRank, Inc.
9+-- (c) 2020 Yuras Shumovich
10+-- License: BSD3
11+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
12+-- Stability: experimental
13+-- Portability: portable
14+--
15+-- Efficiently and correctly parse a JSON string. The string must be
16+-- encoded as UTF-8.
17+
18+module Data.Aeson.Scanner.Internal
19+ (
20+ -- * Lazy scanners
21+ json, jsonEOF
22+ , jsonWith
23+ , jsonLast
24+ , jsonAccum
25+ , jsonNoDup
26+ , value
27+ , jstring
28+ , jstring_
29+ , scientific
30+ -- * Strict scanners
31+ , json', jsonEOF'
32+ , jsonWith'
33+ , jsonLast'
34+ , jsonAccum'
35+ , jsonNoDup'
36+ , value'
37+ -- * Helpers
38+ , decodeWith
39+ , decodeStrictWith
40+ , eitherDecodeWith
41+ , eitherDecodeStrictWith
42+ -- ** Handling objects with duplicate keys
43+ , fromListAccum
44+ , parseListNoDup
45+ ) where
46+
47+import Prelude.Compat
48+
49+import Data.Aeson.Types.Internal
50+import qualified Data.Aeson.Parser.Internal as Parser
51+import Data.Bits (testBit)
52+import Data.ByteString (ByteString)
53+import qualified Data.ByteString.Lazy as Lazy (ByteString)
54+import Data.Function (fix)
55+import Data.Functor.Compat (($>))
56+import Data.HashMap.Strict (HashMap)
57+import qualified Data.HashMap.Strict as HashMap
58+import Data.Scientific (Scientific)
59+import Data.Text (Text)
60+import qualified Data.Text.Encoding as Text
61+import Data.Vector (Vector)
62+import qualified Data.Vector as Vector
63+import Data.Word
64+import Scanner (Scanner)
65+import qualified Scanner
66+import qualified Scanner.Attoparsec as Scanner
67+
68+#define BACKSLASH 92
69+#define CLOSE_CURLY 125
70+#define CLOSE_SQUARE 93
71+#define COMMA 44
72+#define DOUBLE_QUOTE 34
73+#define OPEN_CURLY 123
74+#define OPEN_SQUARE 91
75+#define C_0 48
76+#define C_9 57
77+#define C_A 65
78+#define C_F 70
79+#define C_a 97
80+#define C_f 102
81+#define C_n 110
82+#define C_t 116
83+
84+-- | Parse any JSON value.
85+--
86+-- The conversion of a parsed value to a Haskell value is deferred
87+-- until the Haskell value is needed. This may improve performance if
88+-- only a subset of the results of conversions are needed, but at a
89+-- cost in thunk allocation.
90+--
91+-- This function is an alias for 'value'.
92+--
93+-- ==== Warning
94+--
95+-- If an object contains duplicate keys, only the first one will be kept.
96+-- For a more flexible alternative, see 'jsonWith'.
97+json :: Scanner Value
98+json = value
99+
100+-- | Parse any JSON value.
101+--
102+-- This is a strict version of 'json' which avoids building up thunks
103+-- during parsing; it performs all conversions immediately. Prefer
104+-- this version if most of the JSON data needs to be accessed.
105+--
106+-- This function is an alias for 'value''.
107+--
108+-- ==== Warning
109+--
110+-- If an object contains duplicate keys, only the first one will be kept.
111+-- For a more flexible alternative, see 'jsonWith''.
112+json' :: Scanner Value
113+json' = value'
114+
115+-- Open recursion: object_, object_', array_, array_' are parameterized by the
116+-- toplevel Value parser to be called recursively, to keep the parameter
117+-- mkObject outside of the recursive loop for proper inlining.
118+
119+object_ :: ([(Text, Value)] -> Either String Object)
120+ -> Scanner Value -> Scanner Value
121+object_ mkObject val = {-# SCC "object_" #-} Object
122+ <$> objectValues mkObject jstring val
123+{-# INLINE object_ #-}
124+
125+object_' :: ([(Text, Value)] -> Either String Object)
126+ -> Scanner Value -> Scanner Value
127+object_' mkObject val' = {-# SCC "object_'" #-} do
128+ !vals <- objectValues mkObject jstring' val'
129+ return (Object vals)
130+ where
131+ jstring' = do
132+ !s <- jstring
133+ return s
134+{-# INLINE object_' #-}
135+
136+objectValues :: ([(Text, Value)] -> Either String Object)
137+ -> Scanner Text -> Scanner Value -> Scanner (HashMap Text Value)
138+objectValues mkObject str val = do
139+ skipSpace
140+ w <- lookAhead'
141+ if w == CLOSE_CURLY
142+ then Scanner.anyWord8 $> HashMap.empty
143+ else loop []
144+ where
145+ -- Why use acc pattern here, you may ask? because 'HashMap.fromList' use
146+ -- 'unsafeInsert' and it's much faster because it's doing in place update
147+ -- to the 'HashMap'!
148+ loop acc = do
149+ k <- str <* skipSpace <* Scanner.char8 ':'
150+ v <- val <* skipSpace
151+ ch <- Scanner.satisfy (\w -> w == COMMA || w == CLOSE_CURLY)
152+ let acc' = (k, v) : acc
153+ if ch == COMMA
154+ then skipSpace >> loop acc'
155+ else case mkObject acc' of
156+ Left err -> fail err
157+ Right obj -> pure obj
158+{-# INLINE objectValues #-}
159+
160+array_ :: Scanner Value -> Scanner Value
161+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val
162+{-# INLINE array_ #-}
163+
164+array_' :: Scanner Value -> Scanner Value
165+array_' val = {-# SCC "array_'" #-} do
166+ !vals <- arrayValues val
167+ return (Array vals)
168+{-# INLINE array_' #-}
169+
170+arrayValues :: Scanner Value -> Scanner (Vector Value)
171+arrayValues val = do
172+ skipSpace
173+ w <- lookAhead'
174+ if w == CLOSE_SQUARE
175+ then Scanner.anyWord8 $> Vector.empty
176+ else loop [] 1
177+ where
178+ loop acc !len = do
179+ v <- val <* skipSpace
180+ ch <- Scanner.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE)
181+ if ch == COMMA
182+ then skipSpace >> loop (v:acc) (len+1)
183+ else return (Vector.reverse (Vector.fromListN len (v:acc)))
184+{-# INLINE arrayValues #-}
185+
186+-- | Parse any JSON value. Synonym of 'json'.
187+value :: Scanner Value
188+value = jsonWith (pure . HashMap.fromList)
189+
190+-- | Parse any JSON value.
191+--
192+-- This parser is parameterized by a function to construct an 'Object'
193+-- from a raw list of key-value pairs, where duplicates are preserved.
194+-- The pairs appear in __reverse order__ from the source.
195+--
196+-- ==== __Examples__
197+--
198+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
199+--
200+-- @
201+-- 'json' = 'jsonWith' ('Right' '.' 'HashMap.fromList')
202+-- @
203+--
204+-- 'jsonLast' keeps the last occurence of each key, using
205+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.
206+--
207+-- @
208+-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))
209+-- @
210+--
211+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using
212+-- 'fromListAccum'.
213+--
214+-- @
215+-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')
216+-- @
217+--
218+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.
219+--
220+-- @
221+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'
222+-- @
223+jsonWith :: ([(Text, Value)] -> Either String Object) -> Scanner Value
224+jsonWith mkObject = fix $ \value_ -> do
225+ skipSpace
226+ w <- lookAhead'
227+ case w of
228+ DOUBLE_QUOTE -> Scanner.anyWord8 *> (String <$> jstring_)
229+ OPEN_CURLY -> Scanner.anyWord8 *> object_ mkObject value_
230+ OPEN_SQUARE -> Scanner.anyWord8 *> array_ value_
231+ C_f -> Scanner.string "false" $> Bool False
232+ C_t -> Scanner.string "true" $> Bool True
233+ C_n -> Scanner.string "null" $> Null
234+ _ | w >= 48 && w <= 57 || w == 45
235+ -> Number <$> scientific
236+ | otherwise -> fail "not a valid json value"
237+{-# INLINE jsonWith #-}
238+
239+-- | Variant of 'json' which keeps only the last occurence of every key.
240+jsonLast :: Scanner Value
241+jsonLast = jsonWith (Right . HashMap.fromListWith (const id))
242+
243+-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
244+-- key-value pairs with the same keys.
245+jsonAccum :: Scanner Value
246+jsonAccum = jsonWith (Right . fromListAccum)
247+
248+-- | Variant of 'json' which fails if any object contains duplicate keys.
249+jsonNoDup :: Scanner Value
250+jsonNoDup = jsonWith parseListNoDup
251+
252+-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all
253+-- associated values from the original list @kvs@.
254+--
255+-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]
256+-- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]
257+fromListAccum :: [(Text, Value)] -> Object
258+fromListAccum =
259+ fmap (Array . Vector.fromList . ($ []))
260+ . HashMap.fromListWith (.) . (fmap . fmap) (:)
261+
262+-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
263+parseListNoDup :: [(Text, Value)] -> Either String Object
264+parseListNoDup =
265+ HashMap.traverseWithKey unwrap . HashMap.fromListWith (\_ _ -> Nothing)
266+ . (fmap . fmap) Just
267+ where
268+ unwrap k Nothing = Left $ "found duplicate key: " ++ show k
269+ unwrap _ (Just v) = Right v
270+
271+-- | Strict version of 'value'. Synonym of 'json''.
272+value' :: Scanner Value
273+value' = jsonWith' (pure . HashMap.fromList)
274+
275+-- | Strict version of 'jsonWith'.
276+jsonWith' :: ([(Text, Value)] -> Either String Object) -> Scanner Value
277+jsonWith' mkObject = fix $ \value_ -> do
278+ skipSpace
279+ w <- lookAhead'
280+ case w of
281+ DOUBLE_QUOTE -> do
282+ !s <- Scanner.anyWord8 *> jstring_
283+ return (String s)
284+ OPEN_CURLY -> Scanner.anyWord8 *> object_' mkObject value_
285+ OPEN_SQUARE -> Scanner.anyWord8 *> array_' value_
286+ C_f -> Scanner.string "false" $> Bool False
287+ C_t -> Scanner.string "true" $> Bool True
288+ C_n -> Scanner.string "null" $> Null
289+ _ | w >= 48 && w <= 57 || w == 45
290+ -> do
291+ !n <- scientific
292+ return (Number n)
293+ | otherwise -> fail "not a valid json value"
294+{-# INLINE jsonWith' #-}
295+
296+-- | Variant of 'json'' which keeps only the last occurence of every key.
297+jsonLast' :: Scanner Value
298+jsonLast' = jsonWith' (pure . HashMap.fromListWith (const id))
299+
300+-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve
301+-- key-value pairs with the same keys.
302+jsonAccum' :: Scanner Value
303+jsonAccum' = jsonWith' (pure . fromListAccum)
304+
305+-- | Variant of 'json'' which fails if any object contains duplicate keys.
306+jsonNoDup' :: Scanner Value
307+jsonNoDup' = jsonWith' parseListNoDup
308+
309+-- | Parse a quoted JSON string.
310+jstring :: Scanner Text
311+jstring = Scanner.word8 DOUBLE_QUOTE *> jstring_
312+
313+-- | Parse a string without a leading quote.
314+jstring_ :: Scanner Text
315+{-# INLINE jstring_ #-}
316+jstring_ = do
317+ s <- Scanner.takeWhile $
318+ \w -> w /= DOUBLE_QUOTE && w /= BACKSLASH && not (testBit w 7)
319+ w <- lookAhead'
320+ case w of
321+ DOUBLE_QUOTE -> Scanner.anyWord8 $> Text.decodeUtf8 s
322+ _ -> Scanner.atto $ Parser.jstringSlow s
323+
324+decodeWith :: Scanner Value -> (Value -> Result a) -> Lazy.ByteString -> Maybe a
325+decodeWith p to s =
326+ case Scanner.scanLazy p s of
327+ Right v -> case to v of
328+ Success a -> Just a
329+ _ -> Nothing
330+ _ -> Nothing
331+{-# INLINE decodeWith #-}
332+
333+decodeStrictWith :: Scanner Value -> (Value -> Result a) -> ByteString
334+ -> Maybe a
335+decodeStrictWith p to s =
336+ case either Error to (Scanner.scanOnly p s) of
337+ Success a -> Just a
338+ _ -> Nothing
339+{-# INLINE decodeStrictWith #-}
340+
341+eitherDecodeWith :: Scanner Value -> (Value -> IResult a) -> Lazy.ByteString
342+ -> Either (JSONPath, String) a
343+eitherDecodeWith p to s =
344+ case Scanner.scanLazy p s of
345+ Right v -> case to v of
346+ ISuccess a -> Right a
347+ IError path msg -> Left (path, msg)
348+ Left msg -> Left ([], msg)
349+{-# INLINE eitherDecodeWith #-}
350+
351+eitherDecodeStrictWith :: Scanner Value -> (Value -> IResult a) -> ByteString
352+ -> Either (JSONPath, String) a
353+eitherDecodeStrictWith p to s =
354+ case either (IError []) to (Scanner.scanOnly p s) of
355+ ISuccess a -> Right a
356+ IError path msg -> Left (path, msg)
357+{-# INLINE eitherDecodeStrictWith #-}
358+
359+-- $lazy
360+--
361+-- The 'json' and 'value' parsers decouple identification from
362+-- conversion. Identification occurs immediately (so that an invalid
363+-- JSON document can be rejected as early as possible), but conversion
364+-- to a Haskell value is deferred until that value is needed.
365+--
366+-- This decoupling can be time-efficient if only a smallish subset of
367+-- elements in a JSON value need to be inspected, since the cost of
368+-- conversion is zero for uninspected elements. The trade off is an
369+-- increase in memory usage, due to allocation of thunks for values
370+-- that have not yet been converted.
371+
372+-- $strict
373+--
374+-- The 'json'' and 'value'' parsers combine identification with
375+-- conversion. They consume more CPU cycles up front, but have a
376+-- smaller memory footprint.
377+
378+-- | Parse a top-level JSON value followed by optional whitespace and
379+-- end-of-input. See also: 'json'.
380+jsonEOF :: Scanner Value
381+jsonEOF = json <* skipSpace <* endOfInput
382+
383+-- | Parse a top-level JSON value followed by optional whitespace and
384+-- end-of-input. See also: 'json''.
385+jsonEOF' :: Scanner Value
386+jsonEOF' = json' <* skipSpace <* endOfInput
387+
388+-- | The only valid whitespace in a JSON document is space, newline,
389+-- carriage return, and tab.
390+skipSpace :: Scanner ()
391+skipSpace = Scanner.skipWhile
392+ $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09
393+{-# INLINE skipSpace #-}
394+
395+endOfInput :: Scanner ()
396+endOfInput = do
397+ w <- Scanner.lookAhead
398+ case w of
399+ Nothing -> return ()
400+ Just _ -> fail "input after data"
401+
402+-- | Parse a JSON number.
403+scientific :: Scanner Scientific
404+scientific = Scanner.atto Parser.scientific
405+
406+lookAhead' :: Scanner Word8
407+lookAhead' = Scanner.lookAhead
408+ >>= maybe (fail "unexpected end of input") return