2f24e55 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

improve object/jstring parser

2f24e55winterland198910 years ago

Data/Aeson/Parser/Internal.hs+25−144

compare with master

unifiedsplit

@@ -34,35 +34,20 @@ module Data.Aeson.Parser.Internal

34import Prelude ()

35import Prelude.Compat

37−import Control.Monad.IO.Class (liftIO)

38import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

37import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

39import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,

38import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,

40 skipSpace, string)

39 skipSpace, string)

41−import Data.Bits ((.|.), shiftL)

42−import Data.ByteString.Internal (ByteString(..))

43−import Data.Char (chr)

44import Data.Text (Text)

40import 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)

41+import Data.Vector as Vector (Vector, empty, fromListN, 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)

55import qualified Data.Attoparsec.ByteString as A

42import qualified Data.Attoparsec.ByteString as A

56import qualified Data.Attoparsec.Lazy as L

43import qualified Data.Attoparsec.Lazy as L

57−import qualified Data.Attoparsec.Zepto as Z

58import qualified Data.ByteString as B

44import qualified Data.ByteString as B

59−import qualified Data.ByteString.Internal as B

60import qualified Data.ByteString.Lazy as L

45import qualified Data.ByteString.Lazy as L

61−import qualified Data.ByteString.Unsafe as B

62import qualified Data.HashMap.Strict as H

46import qualified Data.HashMap.Strict as H

47+import Data.Aeson.Parser.Unescape

64#if MIN_VERSION_ghc_prim(0,3,1)

49#if MIN_VERSION_ghc_prim(0,3,1)

65−import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)

50+import GHC.Base (Int#, (==#), isTrue#, word2Int#)

66import GHC.Word (Word8(W8#))

51import GHC.Word (Word8(W8#))

67#endif

52#endif

@@ -125,16 +110,18 @@ objectValues str val = do

125 w <- A.peekWord8'

110 w <- A.peekWord8'

126 if w == CLOSE_CURLY

111 if w == CLOSE_CURLY

127 then A.anyWord8 >> return H.empty

112 then A.anyWord8 >> return H.empty

128− else loop H.empty

113+ else loop []

129 where

114 where

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'!

130− loop m0 = do

117+ loop acc = do

131 k <- str <* skipSpace <* char ':'

118 k <- str <* skipSpace <* char ':'

132 v <- val <* skipSpace

119 v <- val <* skipSpace

133− let !m = H.insert k v m0

134 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY

120 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY

121+ let acc' = (k, v) : acc

135 if ch == COMMA

122 if ch == COMMA

136− then skipSpace >> loop m

123+ then skipSpace >> loop acc'

137− else return m

124+ else return (H.fromList acc')

138{-# INLINE objectValues #-}

125{-# INLINE objectValues #-}

139

126

140array_ :: Parser Value

127array_ :: Parser Value

@@ -151,14 +138,14 @@ arrayValues val = do

151 w <- A.peekWord8'

138 w <- A.peekWord8'

152 if w == CLOSE_SQUARE

139 if w == CLOSE_SQUARE

153 then A.anyWord8 >> return Vector.empty

140 then A.anyWord8 >> return Vector.empty

154− else loop []

141+ else loop [] 1

155 where

142 where

156− loop acc = do

143+ loop acc !len = do

157 v <- val <* skipSpace

144 v <- val <* skipSpace

158 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE

145 ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE

159 if ch == COMMA

146 if ch == COMMA

160− then skipSpace >> loop (v:acc)

147+ then skipSpace >> loop (v:acc) (len+1)

161− else return (Vector.reverse (Vector.fromList (v:acc)))

148+ else return (Vector.reverse (Vector.fromListN len (v:acc)))

162{-# INLINE arrayValues #-}

149{-# INLINE arrayValues #-}

163

150

164-- | Parse any JSON value. You should usually 'json' in preference to

151-- | Parse any JSON value. You should usually 'json' in preference to

@@ -214,101 +201,30 @@ jstring = A.word8 DOUBLE_QUOTE *> jstring_

214jstring_ :: Parser Text

201jstring_ :: Parser Text

215{-# INLINE jstring_ #-}

202{-# INLINE jstring_ #-}

216jstring_ = {-# SCC "jstring_" #-} do

203jstring_ = {-# SCC "jstring_" #-} do

217− (s, fin) <- A.runScanner startState go

204+ s <- A.scan startState go <* A.anyWord8

218− _ <- A.anyWord8

205+ case unescapeText s of

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

225 Right r -> return r

206 Right r -> return r

226 Left err -> fail $ show err

207 Left err -> fail $ show err

227 where

208 where

228#if MIN_VERSION_ghc_prim(0,3,1)

209#if MIN_VERSION_ghc_prim(0,3,1)

229− isEscaped (S _ escaped) = isTrue# escaped

230− startState = S 0# 0#

210+ startState = S 0#

231− go (S a b) (W8# c)

211+ go (S a) (W8# c)

232− | isTrue# a = Just (S 0# b)

212+ | isTrue# a = Just (S 0#)

233 | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote

213 | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote

234 | otherwise = let a' = word2Int# c ==# 92# -- backslash

214 | otherwise = let a' = word2Int# c ==# 92# -- backslash

235− in Just (S a' (orI# a' b))

215+ in Just (S a')

236

216

237−data S = S Int# Int#

217+data S = S Int#

238#else

218#else

239− isEscaped (S _ escaped) = escaped

240− startState = S False False

219+ startState = False

241− go (S a b) c

220+ go a c

242− | a = Just (S False b)

221+ | a = Just False

243 | c == DOUBLE_QUOTE = Nothing

222 | c == DOUBLE_QUOTE = Nothing

244 | otherwise = let a' = c == backslash

223 | otherwise = let a' = c == backslash

245− in Just (S a' (a' || b))

224+ in Just a'

246 where backslash = BACKSLASH

225 where backslash = BACKSLASH

247−

248−data S = S !Bool !Bool

249#endif

226#endif

250

227

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−

312decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a

228decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a

313decodeWith p to s =

229decodeWith p to s =

314 case L.parse p s of

230 case L.parse p s of

@@ -372,38 +288,3 @@ jsonEOF = json <* skipSpace <* endOfInput

372-- end-of-input. See also: 'json''.

288-- end-of-input. See also: 'json''.

373jsonEOF' :: Parser Value

289jsonEOF' :: Parser Value

374jsonEOF' = json' <* skipSpace <* endOfInput

290jsonEOF' = 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 #-}

5+module Data.Aeson.Parser.Unescape (

6+ unescapeText

7+) where

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:

52 examples/*.hs

53 examples/Twitter/*.hs

54 include/*.h

55+ cbits/*.c

56flag developer

57flag developer

57 description: operate in developer mode

58 description: operate in developer mode

@@ -86,6 +87,7 @@ library

86 Data.Aeson.Encoding.Builder

87 Data.Aeson.Encoding.Builder

87 Data.Aeson.Internal.Functions

88 Data.Aeson.Internal.Functions

88 Data.Aeson.Parser.Internal

89 Data.Aeson.Parser.Internal

90+ Data.Aeson.Parser.Unescape

89 Data.Aeson.Parser.Time

91 Data.Aeson.Parser.Time

90 Data.Aeson.Types.FromJSON

92 Data.Aeson.Types.FromJSON

91 Data.Aeson.Types.Generic

93 Data.Aeson.Types.Generic

@@ -136,6 +138,7 @@ library

136 ghc-options: -O2 -Wall

138 ghc-options: -O2 -Wall

137

139

138 include-dirs: include

140 include-dirs: include

141+ c-sources: cbits/unescape_string.c

139

142

140test-suite tests

143test-suite tests

141 default-language: Haskell2010

144 default-language: Haskell2010

benchmarks/aeson-benchmarks.cabal+1−1

@@ -11,7 +11,7 @@ flag bytestring-builder

12library

13 hs-source-dirs: .. .

14−

14+ c-sources: ../cbits/unescape_string.c

15 exposed-modules:

16 Data.Aeson

17 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>

6+#define UTF8_ACCEPT 0

7+#define UTF8_REJECT 12

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+