git.iko.soy/typeable/aeson
on master help sign in
improve object/jstring parser
commit2f24e555d86a36fdda6d4cad79976004b382ab3b authorwinterland1989 <winterland1989@gmail.com> dateFri 15 Jul 2016, 19:23 (10 years ago) parent2d2b699
5 files changed+230−145
compare with master
unifiedsplit
Data/Aeson/Parser/Internal.hs+25−144 Data/Aeson/Parser/Unescape.hs+51 aeson.cabal+3 benchmarks/aeson-benchmarks.cabal+1−1 cbits/unescape_string.c+150
Data/Aeson/Parser/Internal.hs+25−144
@@ -34,35 +34,20 @@ module Data.Aeson.Parser.Internal
3434import Prelude ()
3535import Prelude.Compat
3636
37−import Control.Monad.IO.Class (liftIO)
3837import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
3938import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,
4039 skipSpace, string)
41−import Data.Bits ((.|.), shiftL)
42−import Data.ByteString.Internal (ByteString(..))
43−import Data.Char (chr)
4440import Data.Text (Text)
45−import Data.Text.Encoding (decodeUtf8')
46−import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)
47−import Data.Text.Internal.Unsafe.Char (ord)
48−import Data.Vector as Vector (Vector, empty, fromList, reverse)
49−import Data.Word (Word8)
50−import Foreign.ForeignPtr (withForeignPtr)
51−import Foreign.Marshal.Utils (copyBytes)
52−import Foreign.Ptr (Ptr, minusPtr, plusPtr)
53−import Foreign.Storable (poke)
54−import System.IO.Unsafe (unsafePerformIO)
41+import Data.Vector as Vector (Vector, empty, fromListN, reverse)
5542import qualified Data.Attoparsec.ByteString as A
5643import qualified Data.Attoparsec.Lazy as L
57−import qualified Data.Attoparsec.Zepto as Z
5844import qualified Data.ByteString as B
59−import qualified Data.ByteString.Internal as B
6045import qualified Data.ByteString.Lazy as L
61−import qualified Data.ByteString.Unsafe as B
6246import qualified Data.HashMap.Strict as H
47+import Data.Aeson.Parser.Unescape
6348
6449#if MIN_VERSION_ghc_prim(0,3,1)
65−import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)
50+import GHC.Base (Int#, (==#), isTrue#, word2Int#)
6651import GHC.Word (Word8(W8#))
6752#endif
6853
@@ -125,16 +110,18 @@ objectValues str val = do
125110 w <- A.peekWord8'
126111 if w == CLOSE_CURLY
127112 then A.anyWord8 >> return H.empty
128− else loop H.empty
113+ else loop []
129114 where
130− loop m0 = do
115+ -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'
116+ -- and it's much faster because it's doing in place update to the 'HashMap'!
117+ loop acc = do
131118 k <- str <* skipSpace <* char ':'
132119 v <- val <* skipSpace
133− let !m = H.insert k v m0
134120 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY
121+ let acc' = (k, v) : acc
135122 if ch == COMMA
136− then skipSpace >> loop m
137− else return m
123+ then skipSpace >> loop acc'
124+ else return (H.fromList acc')
138125{-# INLINE objectValues #-}
139126
140127array_ :: Parser Value
@@ -151,14 +138,14 @@ arrayValues val = do
151138 w <- A.peekWord8'
152139 if w == CLOSE_SQUARE
153140 then A.anyWord8 >> return Vector.empty
154− else loop []
141+ else loop [] 1
155142 where
156− loop acc = do
143+ loop acc !len = do
157144 v <- val <* skipSpace
158145 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE
159146 if ch == COMMA
160− then skipSpace >> loop (v:acc)
161− else return (Vector.reverse (Vector.fromList (v:acc)))
147+ then skipSpace >> loop (v:acc) (len+1)
148+ else return (Vector.reverse (Vector.fromListN len (v:acc)))
162149{-# INLINE arrayValues #-}
163150
164151-- | Parse any JSON value. You should usually 'json' in preference to
@@ -214,101 +201,30 @@ jstring = A.word8 DOUBLE_QUOTE *> jstring_
214201jstring_ :: Parser Text
215202{-# INLINE jstring_ #-}
216203jstring_ = {-# SCC "jstring_" #-} do
217− (s, fin) <- A.runScanner startState go
218− _ <- A.anyWord8
219− s1 <- if isEscaped fin
220− then case unescape s of
221− Right r -> return r
222− Left err -> fail err
223− else return s
224− case decodeUtf8' s1 of
204+ s <- A.scan startState go <* A.anyWord8
205+ case unescapeText s of
225206 Right r -> return r
226207 Left err -> fail $ show err
227208 where
228209#if MIN_VERSION_ghc_prim(0,3,1)
229− isEscaped (S _ escaped) = isTrue# escaped
230− startState = S 0# 0#
231− go (S a b) (W8# c)
232− | isTrue# a = Just (S 0# b)
210+ startState = S 0#
211+ go (S a) (W8# c)
212+ | isTrue# a = Just (S 0#)
233213 | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote
234214 | otherwise = let a' = word2Int# c ==# 92# -- backslash
235− in Just (S a' (orI# a' b))
215+ in Just (S a')
236216
237−data S = S Int# Int#
217+data S = S Int#
238218#else
239− isEscaped (S _ escaped) = escaped
240− startState = S False False
241− go (S a b) c
242− | a = Just (S False b)
219+ startState = False
220+ go a c
221+ | a = Just False
243222 | c == DOUBLE_QUOTE = Nothing
244223 | otherwise = let a' = c == backslash
245− in Just (S a' (a' || b))
224+ in Just a'
246225 where backslash = BACKSLASH
247−
248−data S = S !Bool !Bool
249226#endif
250227
251−unescape :: ByteString -> Either String ByteString
252−unescape s = unsafePerformIO $ do
253− let len = B.length s
254− fp <- B.mallocByteString len
255− -- We perform no bounds checking when writing to the destination
256− -- string, as unescaping always makes it shorter than the source.
257− withForeignPtr fp $ \ptr -> do
258− ret <- Z.parseT (go ptr) s
259− case ret of
260− Left err -> return (Left err)
261− Right p -> do
262− let newlen = p `minusPtr` ptr
263− slop = len - newlen
264− Right <$> if slop >= 128 && slop >= len `quot` 4
265− then B.create newlen $ \np -> copyBytes np ptr newlen
266− else return (PS fp 0 newlen)
267− where
268− go ptr = do
269− h <- Z.takeWhile (/=BACKSLASH)
270− let rest = do
271− start <- Z.take 2
272− let !slash = B.unsafeHead start
273− !t = B.unsafeIndex start 1
274− escape = case B.elemIndex t "\"\\/ntbrfu" of
275− Just i -> i
276− _ -> 255
277− if slash /= BACKSLASH || escape == 255
278− then fail "invalid JSON escape sequence"
279− else
280− if t /= 117 -- 'u'
281− then copy h ptr >>= word8 (B.unsafeIndex mapping escape) >>= go
282− else do
283− a <- hexQuad
284− if a < 0xd800 || a > 0xdfff
285− then copy h ptr >>= charUtf8 (chr a) >>= go
286− else do
287− b <- Z.string "\\u" *> hexQuad
288− if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
289− then let !c = ((a - 0xd800) `shiftL` 10) +
290− (b - 0xdc00) + 0x10000
291− in copy h ptr >>= charUtf8 (chr c) >>= go
292− else fail "invalid UTF-16 surrogates"
293− done <- Z.atEnd
294− if done
295− then copy h ptr
296− else rest
297− mapping = "\"\\/\n\t\b\r\f"
298−
299−hexQuad :: Z.ZeptoT IO Int
300−hexQuad = do
301− s <- Z.take 4
302− let hex n | w >= C_0 && w <= C_9 = w - C_0
303− | w >= C_a && w <= C_f = w - 87
304− | w >= C_A && w <= C_F = w - 55
305− | otherwise = 255
306− where w = fromIntegral $ B.unsafeIndex s n
307− a = hex 0; b = hex 1; c = hex 2; d = hex 3
308− if (a .|. b .|. c .|. d) /= 255
309− then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)
310− else fail "invalid hex escape"
311−
312228decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a
313229decodeWith p to s =
314230 case L.parse p s of
@@ -372,38 +288,3 @@ jsonEOF = json <* skipSpace <* endOfInput
372288-- end-of-input. See also: 'json''.
373289jsonEOF' :: Parser Value
374290jsonEOF' = json' <* skipSpace <* endOfInput
375−
376−word8 :: Word8 -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
377−word8 w ptr = do
378− liftIO $ poke ptr w
379− return $! ptr `plusPtr` 1
380−
381−copy :: ByteString -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
382−copy (PS fp off len) ptr =
383− liftIO . withForeignPtr fp $ \src -> do
384− copyBytes ptr (src `plusPtr` off) len
385− return $! ptr `plusPtr` len
386−
387−charUtf8 :: Char -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
388−charUtf8 ch ptr
389− | ch < '\x80' = liftIO $ do
390− poke ptr (fromIntegral (ord ch))
391− return $! ptr `plusPtr` 1
392− | ch < '\x800' = liftIO $ do
393− let (a,b) = ord2 ch
394− poke ptr a
395− poke (ptr `plusPtr` 1) b
396− return $! ptr `plusPtr` 2
397− | ch < '\xffff' = liftIO $ do
398− let (a,b,c) = ord3 ch
399− poke ptr a
400− poke (ptr `plusPtr` 1) b
401− poke (ptr `plusPtr` 2) c
402− return $! ptr `plusPtr` 3
403− | otherwise = liftIO $ do
404− let (a,b,c,d) = ord4 ch
405− poke ptr a
406− poke (ptr `plusPtr` 1) b
407− poke (ptr `plusPtr` 2) c
408− poke (ptr `plusPtr` 3) d
409− return $! ptr `plusPtr` 4
Data/Aeson/Parser/Unescape.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnliftedFFITypes #-}
4+
5+module Data.Aeson.Parser.Unescape (
6+ unescapeText
7+) where
8+
9+import Control.Exception (evaluate, throw, try)
10+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
11+import Data.ByteString as B
12+import Data.ByteString.Internal as B hiding (c2w)
13+import qualified Data.Text.Array as A
14+import Data.Text.Encoding.Error (UnicodeException (..))
15+import Data.Text.Internal (Text (..))
16+import Data.Text.Internal.Private (runText)
17+import Data.Text.Unsafe (unsafeDupablePerformIO)
18+import Data.Word (Word8)
19+import Foreign.C.Types (CInt (..), CSize (..))
20+import Foreign.ForeignPtr (withForeignPtr)
21+import Foreign.Marshal.Utils (with)
22+import Foreign.Ptr (Ptr, plusPtr)
23+import Foreign.Storable (peek)
24+import GHC.Base (MutableByteArray#)
25+
26+foreign import ccall unsafe "_js_decode_string" c_js_decode
27+ :: MutableByteArray# s -> Ptr CSize
28+ -> Ptr Word8 -> Ptr Word8 -> IO CInt
29+
30+unescapeText' :: ByteString -> Text
31+unescapeText' (PS fp off len) = runText $ \done -> do
32+ let go dest = withForeignPtr fp $ \ptr ->
33+ with (0::CSize) $ \destOffPtr -> do
34+ let end = ptr `plusPtr` (off + len)
35+ loop curPtr = do
36+ res <- c_js_decode (A.maBA dest) destOffPtr curPtr end
37+ case res of
38+ 0 -> do
39+ n <- peek destOffPtr
40+ unsafeSTToIO (done dest (fromIntegral n))
41+ _ ->
42+ throw (DecodeError desc Nothing)
43+ loop (ptr `plusPtr` off)
44+ (unsafeIOToST . go) =<< A.new len
45+ where
46+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
47+{-# INLINE unescapeText' #-}
48+
49+unescapeText :: ByteString -> Either UnicodeException Text
50+unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'
51+{-# INLINE unescapeText #-}
aeson.cabal+3
@@ -52,6 +52,7 @@ extra-source-files:
5252 examples/*.hs
5353 examples/Twitter/*.hs
5454 include/*.h
55+ cbits/*.c
5556
5657flag developer
5758 description: operate in developer mode
@@ -86,6 +87,7 @@ library
8687 Data.Aeson.Encoding.Builder
8788 Data.Aeson.Internal.Functions
8889 Data.Aeson.Parser.Internal
90+ Data.Aeson.Parser.Unescape
8991 Data.Aeson.Parser.Time
9092 Data.Aeson.Types.FromJSON
9193 Data.Aeson.Types.Generic
@@ -136,6 +138,7 @@ library
136138 ghc-options: -O2 -Wall
137139
138140 include-dirs: include
141+ c-sources: cbits/unescape_string.c
139142
140143test-suite tests
141144 default-language: Haskell2010
benchmarks/aeson-benchmarks.cabal+1−1
@@ -11,7 +11,7 @@ flag bytestring-builder
1111
1212library
1313 hs-source-dirs: .. .
14−
14+ c-sources: ../cbits/unescape_string.c
1515 exposed-modules:
1616 Data.Aeson
1717 Data.Aeson.Encoding
cbits/unescape_string.cnew file+150
@@ -0,0 +1,150 @@
1+#include <string.h>
2+#include <stdio.h>
3+#include <stdint.h>
4+
5+
6+#define UTF8_ACCEPT 0
7+#define UTF8_REJECT 12
8+
9+static const uint8_t utf8d[] = {
10+ // The first part of the table maps bytes to character classes that
11+ // to reduce the size of the transition table and create bitmasks.
12+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
13+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
14+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
16+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
17+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
18+ 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
19+ 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
20+
21+ // The second part is a transition table that maps a combination
22+ // of a state of the automaton and a character class to a state.
23+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
24+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
25+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
26+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
27+ 12,36,12,12,12,12,12,12,12,12,12,12,
28+};
29+
30+static inline uint32_t decode(uint32_t* state, uint32_t* codep, uint32_t byte) {
31+ uint32_t type = utf8d[byte];
32+
33+ *codep = (*state != UTF8_ACCEPT) ?
34+ (byte & 0x3fu) | (*codep << 6) :
35+ (0xff >> type) & (byte);
36+
37+ *state = utf8d[256 + *state + type];
38+ return *state;
39+}
40+
41+static inline uint16_t decode_hex(uint32_t c)
42+{
43+ if (c >= '0' && c <= '9') return c - '0';
44+ else if (c >= 'a' && c <= 'f') return c - 'a' + 10;
45+ else if (c >= 'A' && c <= 'F') return c - 'A' + 10;
46+ return 0xFFFF; // Should not happen
47+}
48+
49+// Decode, return non-zero value on error
50+int _js_decode_string(uint16_t *const dest, size_t *destoff,
51+ const uint8_t *s, const uint8_t *const srcend)
52+{
53+ uint16_t *d = dest + *destoff;
54+ uint32_t state = 0;
55+ uint32_t codepoint;
56+
57+ uint8_t surrogate = 0;
58+ uint16_t temp_hex = 0;
59+ uint16_t unidata;
60+
61+ // Optimized version of dispatch when just an ASCII char is expected
62+ #define DISPATCH_ASCII(label) {\
63+ if (s >= srcend) {\
64+ return -1;\
65+ }\
66+ codepoint = *s++;\
67+ goto label;\
68+ }
69+
70+ standard:
71+ // Test end of stream
72+ while (s < srcend) {
73+ if (*s <= 127)
74+ codepoint = *s++;
75+ else if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {
76+ if (state == UTF8_REJECT) { return -1; }
77+ continue;
78+ }
79+
80+ if (codepoint == '\\')
81+ DISPATCH_ASCII(backslash)
82+ else if (codepoint <= 0xffff)
83+ *d++ = (uint16_t) codepoint;
84+ else {
85+ *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));
86+ *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));
87+ }
88+ }
89+ *destoff = d - dest;
90+ // Exit point
91+ return (state != UTF8_ACCEPT);
92+ backslash:
93+ switch (codepoint) {
94+ case '"':
95+ case '\\':
96+ case '/':
97+ *d++ = (uint16_t) codepoint;
98+ goto standard;
99+ break;
100+ case 'b': *d++ = '\b';goto standard;
101+ case 'f': *d++ = '\f';goto standard;
102+ case 'n': *d++ = '\n';goto standard;
103+ case 'r': *d++ = '\r';goto standard;
104+ case 't': *d++ = '\t';goto standard;
105+ case 'u': DISPATCH_ASCII(unicode1);;break;
106+ default:
107+ return -1;
108+ }
109+ unicode1:
110+ temp_hex = decode_hex(codepoint);
111+ if (temp_hex == 0xFFFF) { return -1; }
112+ else unidata = temp_hex << 12;
113+ DISPATCH_ASCII(unicode2);
114+ unicode2:
115+ temp_hex = decode_hex(codepoint);
116+ if (temp_hex == 0xFFFF) { return -1; }
117+ else unidata |= temp_hex << 8;
118+ DISPATCH_ASCII(unicode3);
119+ unicode3:
120+ temp_hex = decode_hex(codepoint);
121+ if (temp_hex == 0xFFFF) { return -1; }
122+ else unidata |= temp_hex << 4;
123+ DISPATCH_ASCII(unicode4);
124+ unicode4:
125+ temp_hex = decode_hex(codepoint);
126+ if (temp_hex == 0xFFFF) { return -1; }
127+ else unidata |= temp_hex;
128+ *d++ = (uint16_t) unidata;
129+
130+ if (surrogate) {
131+ if (unidata <= 0xDC00 || unidata >= 0xDFFF) // is not low surrogate
132+ return -1;
133+ surrogate = 0;
134+ } else if (unidata >= 0xD800 && unidata <= 0xDBFF ) { // is high surrogate
135+ surrogate = 1;
136+ DISPATCH_ASCII(surrogate1);
137+ } else if (unidata >= 0xDC00 && unidata <= 0xDFFF) { // is low surrogate
138+ return -1;
139+ }
140+ goto standard;
141+ surrogate1:
142+ if (codepoint != '\\')
143+ return -1;
144+ DISPATCH_ASCII(surrogate2)
145+ surrogate2:
146+ if (codepoint != 'u')
147+ return -1;
148+ DISPATCH_ASCII(unicode1)
149+}
150+