47bc68f · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #458 from winterland1989/master

47bc68fAdam Bergmark10 years ago

Data/Aeson/Parser/Internal.hs+26−141

compare with master

unifiedsplit

@@ -36,34 +36,23 @@ module Data.Aeson.Parser.Internal

36import Prelude ()

37import Prelude.Compat

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

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

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

41import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string)

40import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string)

41+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string)

42import Data.Bits ((.|.), shiftL)

43import Data.ByteString.Internal (ByteString(..))

44import Data.Char (chr)

45import Data.Text (Text)

46−import Data.Text.Encoding (decodeUtf8')

47−import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)

48−import Data.Text.Internal.Unsafe.Char (ord)

49−import Data.Vector as Vector (Vector, empty, fromList, reverse)

46+import Data.Vector as Vector (Vector, empty, fromListN, reverse)

50−import Data.Word (Word8)

51−import Foreign.ForeignPtr (withForeignPtr)

52−import Foreign.Marshal.Utils (copyBytes)

53−import Foreign.Ptr (Ptr, minusPtr, plusPtr)

54−import Foreign.Storable (poke)

55−import System.IO.Unsafe (unsafePerformIO)

56import qualified Data.Attoparsec.ByteString as A

47import qualified Data.Attoparsec.ByteString as A

57import qualified Data.Attoparsec.Lazy as L

48import qualified Data.Attoparsec.Lazy as L

58−import qualified Data.Attoparsec.Zepto as Z

59import qualified Data.ByteString as B

49import qualified Data.ByteString as B

60−import qualified Data.ByteString.Internal as B

61import qualified Data.ByteString.Lazy as L

50import qualified Data.ByteString.Lazy as L

62−import qualified Data.ByteString.Unsafe as B

63import qualified Data.HashMap.Strict as H

51import qualified Data.HashMap.Strict as H

52+import Data.Aeson.Parser.Unescape

65#if MIN_VERSION_ghc_prim(0,3,1)

54#if MIN_VERSION_ghc_prim(0,3,1)

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

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

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

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

68#endif

57#endif

@@ -126,16 +115,18 @@ objectValues str val = do

126 w <- A.peekWord8'

115 w <- A.peekWord8'

127 if w == CLOSE_CURLY

116 if w == CLOSE_CURLY

128 then A.anyWord8 >> return H.empty

117 then A.anyWord8 >> return H.empty

129− else loop H.empty

118+ else loop []

130 where

119 where

120+ -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'

121+ -- and it's much faster because it's doing in place update to the 'HashMap'!

131− loop m0 = do

122+ loop acc = do

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

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

133 v <- val <* skipSpace

124 v <- val <* skipSpace

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

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

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

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

136 if ch == COMMA

127 if ch == COMMA

137− then skipSpace >> loop m

128+ then skipSpace >> loop acc'

138− else return m

129+ else return (H.fromList acc')

139{-# INLINE objectValues #-}

130{-# INLINE objectValues #-}

140

131

141array_ :: Parser Value

132array_ :: Parser Value

@@ -152,14 +143,14 @@ arrayValues val = do

152 w <- A.peekWord8'

143 w <- A.peekWord8'

153 if w == CLOSE_SQUARE

144 if w == CLOSE_SQUARE

154 then A.anyWord8 >> return Vector.empty

145 then A.anyWord8 >> return Vector.empty

155− else loop []

146+ else loop [] 1

156 where

147 where

157− loop acc = do

148+ loop acc !len = do

158 v <- val <* skipSpace

149 v <- val <* skipSpace

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

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

160 if ch == COMMA

151 if ch == COMMA

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

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

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

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

163{-# INLINE arrayValues #-}

154{-# INLINE arrayValues #-}

164

155

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

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

@@ -215,101 +206,30 @@ jstring = A.word8 DOUBLE_QUOTE *> jstring_

215jstring_ :: Parser Text

206jstring_ :: Parser Text

216{-# INLINE jstring_ #-}

207{-# INLINE jstring_ #-}

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

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

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

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

219− _ <- A.anyWord8

210+ case unescapeText s of

220− s1 <- if isEscaped fin

221− then case unescape s of

222− Right r -> return r

223− Left err -> fail err

224− else return s

225− case decodeUtf8' s1 of

226 Right r -> return r

211 Right r -> return r

227 Left err -> fail $ show err

212 Left err -> fail $ show err

228 where

213 where

229#if MIN_VERSION_ghc_prim(0,3,1)

214#if MIN_VERSION_ghc_prim(0,3,1)

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

231− startState = S 0# 0#

215+ startState = S 0#

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

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

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

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

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

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

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

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

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

220+ in Just (S a')

237

221

238−data S = S Int# Int#

222+data S = S Int#

239#else

223#else

240− isEscaped (S _ escaped) = escaped

241− startState = S False False

224+ startState = False

242− go (S a b) c

225+ go a c

243− | a = Just (S False b)

226+ | a = Just False

244 | c == DOUBLE_QUOTE = Nothing

227 | c == DOUBLE_QUOTE = Nothing

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

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

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

229+ in Just a'

247 where backslash = BACKSLASH

230 where backslash = BACKSLASH

248−

249−data S = S !Bool !Bool

250#endif

231#endif

251

232

252−unescape :: ByteString -> Either String ByteString

253−unescape s = unsafePerformIO $ do

254− let len = B.length s

255− fp <- B.mallocByteString len

256− -- We perform no bounds checking when writing to the destination

257− -- string, as unescaping always makes it shorter than the source.

258− withForeignPtr fp $ \ptr -> do

259− ret <- Z.parseT (go ptr) s

260− case ret of

261− Left err -> return (Left err)

262− Right p -> do

263− let newlen = p `minusPtr` ptr

264− slop = len - newlen

265− Right <$> if slop >= 128 && slop >= len `quot` 4

266− then B.create newlen $ \np -> copyBytes np ptr newlen

267− else return (PS fp 0 newlen)

268− where

269− go ptr = do

270− h <- Z.takeWhile (/=BACKSLASH)

271− let rest = do

272− start <- Z.take 2

273− let !slash = B.unsafeHead start

274− !t = B.unsafeIndex start 1

275− escape = case B.elemIndex t "\"\\/ntbrfu" of

276− Just i -> i

277− _ -> 255

278− if slash /= BACKSLASH || escape == 255

279− then fail "invalid JSON escape sequence"

280− else

281− if t /= 117 -- 'u'

282− then copy h ptr >>= word8 (B.unsafeIndex mapping escape) >>= go

283− else do

284− a <- hexQuad

285− if a < 0xd800 || a > 0xdfff

286− then copy h ptr >>= charUtf8 (chr a) >>= go

287− else do

288− b <- Z.string "\\u" *> hexQuad

289− if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff

290− then let !c = ((a - 0xd800) `shiftL` 10) +

291− (b - 0xdc00) + 0x10000

292− in copy h ptr >>= charUtf8 (chr c) >>= go

293− else fail "invalid UTF-16 surrogates"

294− done <- Z.atEnd

295− if done

296− then copy h ptr

297− else rest

298− mapping = "\"\\/\n\t\b\r\f"

299−

300−hexQuad :: Z.ZeptoT IO Int

301−hexQuad = do

302− s <- Z.take 4

303− let hex n | w >= C_0 && w <= C_9 = w - C_0

304− | w >= C_a && w <= C_f = w - 87

305− | w >= C_A && w <= C_F = w - 55

306− | otherwise = 255

307− where w = fromIntegral $ B.unsafeIndex s n

308− a = hex 0; b = hex 1; c = hex 2; d = hex 3

309− if (a .|. b .|. c .|. d) /= 255

310− then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)

311− else fail "invalid hex escape"

312−

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

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

314decodeWith p to s =

234decodeWith p to s =

315 case L.parse p s of

235 case L.parse p s of

@@ -373,38 +293,3 @@ jsonEOF = json <* skipSpace <* endOfInput

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

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

374jsonEOF' :: Parser Value

294jsonEOF' :: Parser Value

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

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

376−

377−word8 :: Word8 -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)

378−word8 w ptr = do

379− liftIO $ poke ptr w

380− return $! ptr `plusPtr` 1

381−

382−copy :: ByteString -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)

383−copy (PS fp off len) ptr =

384− liftIO . withForeignPtr fp $ \src -> do

385− copyBytes ptr (src `plusPtr` off) len

386− return $! ptr `plusPtr` len

387−

388−charUtf8 :: Char -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)

389−charUtf8 ch ptr

390− | ch < '\x80' = liftIO $ do

391− poke ptr (fromIntegral (ord ch))

392− return $! ptr `plusPtr` 1

393− | ch < '\x800' = liftIO $ do

394− let (a,b) = ord2 ch

395− poke ptr a

396− poke (ptr `plusPtr` 1) b

397− return $! ptr `plusPtr` 2

398− | ch < '\xffff' = liftIO $ do

399− let (a,b,c) = ord3 ch

400− poke ptr a

401− poke (ptr `plusPtr` 1) b

402− poke (ptr `plusPtr` 2) c

403− return $! ptr `plusPtr` 3

404− | otherwise = liftIO $ do

405− let (a,b,c,d) = ord4 ch

406− poke ptr a

407− poke (ptr `plusPtr` 1) b

408− poke (ptr `plusPtr` 2) c

409− poke (ptr `plusPtr` 3) d

410− 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

@@ -91,6 +92,7 @@ library

91 Data.Aeson.Encoding.Builder

92 Data.Aeson.Encoding.Builder

92 Data.Aeson.Internal.Functions

93 Data.Aeson.Internal.Functions

93 Data.Aeson.Parser.Internal

94 Data.Aeson.Parser.Internal

95+ Data.Aeson.Parser.Unescape

94 Data.Aeson.Parser.Time

96 Data.Aeson.Parser.Time

95 Data.Aeson.Types.FromJSON

97 Data.Aeson.Types.FromJSON

96 Data.Aeson.Types.Generic

98 Data.Aeson.Types.Generic

@@ -146,6 +148,7 @@ library

146 ghc-options: -O2

148 ghc-options: -O2

147

149

148 include-dirs: include

150 include-dirs: include

151+ c-sources: cbits/unescape_string.c

149

152

150test-suite tests

153test-suite tests

151 default-language: Haskell2010

154 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 @@

5+#include <string.h>

6+#include <stdio.h>

7+#include <stdint.h>

10+#define UTF8_ACCEPT 0

11+#define UTF8_REJECT 12

12+

13+static const uint8_t utf8d[] = {

14+ // The first part of the table maps bytes to character classes that

15+ // to reduce the size of the transition table and create bitmasks.

16+ 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,

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

18+ 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,

19+ 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,

20+ 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,

21+ 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,

22+ 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,

23+ 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,

24+

25+ // The second part is a transition table that maps a combination

26+ // of a state of the automaton and a character class to a state.

27+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,

28+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

29+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

30+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

31+ 12,36,12,12,12,12,12,12,12,12,12,12,

32+};

33+

34+static inline uint32_t decode(uint32_t* state, uint32_t* codep, uint32_t byte) {

35+ uint32_t type = utf8d[byte];

36+

37+ *codep = (*state != UTF8_ACCEPT) ?

38+ (byte & 0x3fu) | (*codep << 6) :

39+ (0xff >> type) & (byte);

40+

41+ *state = utf8d[256 + *state + type];

42+ return *state;

43+}

44+

45+static inline uint16_t decode_hex(uint32_t c)

46+{

47+ if (c >= '0' && c <= '9') return c - '0';

48+ else if (c >= 'a' && c <= 'f') return c - 'a' + 10;

49+ else if (c >= 'A' && c <= 'F') return c - 'A' + 10;

50+ return 0xFFFF; // Should not happen

51+}

52+

53+// Decode, return non-zero value on error

54+int _js_decode_string(uint16_t *const dest, size_t *destoff,

55+ const uint8_t *s, const uint8_t *const srcend)

56+{

57+ uint16_t *d = dest + *destoff;

58+ uint32_t state = 0;

59+ uint32_t codepoint;

60+

61+ uint8_t surrogate = 0;

62+ uint16_t temp_hex = 0;

63+ uint16_t unidata;

64+

65+ // Optimized version of dispatch when just an ASCII char is expected

66+ #define DISPATCH_ASCII(label) {\

67+ if (s >= srcend) {\

68+ return -1;\

69+ }\

70+ codepoint = *s++;\

71+ goto label;\

72+ }

73+

74+ standard:

75+ // Test end of stream

76+ while (s < srcend) {

77+ if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {

78+ if (state == UTF8_REJECT) { return -1; }

79+ continue;

80+ }

81+

82+ if (codepoint == '\\')

83+ DISPATCH_ASCII(backslash)

84+ else if (codepoint <= 0xffff)

85+ *d++ = (uint16_t) codepoint;

86+ else {

87+ *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));

88+ *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));

89+ }

90+ }

91+ *destoff = d - dest;

92+ // Exit point

93+ return (state != UTF8_ACCEPT);

94+ backslash:

95+ switch (codepoint) {

96+ case '"':

97+ case '\\':

98+ case '/':

99+ *d++ = (uint16_t) codepoint;

100+ goto standard;

101+ break;

102+ case 'b': *d++ = '\b';goto standard;

103+ case 'f': *d++ = '\f';goto standard;

104+ case 'n': *d++ = '\n';goto standard;

105+ case 'r': *d++ = '\r';goto standard;

106+ case 't': *d++ = '\t';goto standard;

107+ case 'u': DISPATCH_ASCII(unicode1);;break;

108+ default:

109+ return -1;

110+ }

111+ unicode1:

112+ temp_hex = decode_hex(codepoint);

113+ if (temp_hex == 0xFFFF) { return -1; }

114+ else unidata = temp_hex << 12;

115+ DISPATCH_ASCII(unicode2);

116+ unicode2:

117+ temp_hex = decode_hex(codepoint);

118+ if (temp_hex == 0xFFFF) { return -1; }

119+ else unidata |= temp_hex << 8;

120+ DISPATCH_ASCII(unicode3);

121+ unicode3:

122+ temp_hex = decode_hex(codepoint);

123+ if (temp_hex == 0xFFFF) { return -1; }

124+ else unidata |= temp_hex << 4;

125+ DISPATCH_ASCII(unicode4);

126+ unicode4:

127+ temp_hex = decode_hex(codepoint);

128+ if (temp_hex == 0xFFFF) { return -1; }

129+ else unidata |= temp_hex;

130+ *d++ = (uint16_t) unidata;

131+

132+ if (surrogate) {

133+ if (unidata <= 0xDC00 || unidata >= 0xDFFF) // is not low surrogate

134+ return -1;

135+ surrogate = 0;

136+ } else if (unidata >= 0xD800 && unidata <= 0xDBFF ) { // is high surrogate

137+ surrogate = 1;

138+ DISPATCH_ASCII(surrogate1);

139+ } else if (unidata >= 0xDC00 && unidata <= 0xDFFF) { // is low surrogate

140+ return -1;

141+ }

142+ goto standard;

143+ surrogate1:

144+ if (codepoint != '\\') { return -1; }

145+ DISPATCH_ASCII(surrogate2)

146+ surrogate2:

147+ if (codepoint != 'u') { return -1; }

148+ DISPATCH_ASCII(unicode1)

149+}

150+