47bc68f · typeable/aeson

git.iko.soy/typeable/aeson

Merge pull request #458 from winterland1989/master

commit47bc68f65481379c7060ed72caeba599ef650a09 authorAdam Bergmark <adam@bergmark.nl> dateFri 16 Sep 2016, 17:20 (10 years ago) parentd8dafae 6d2e0a8

5 files changed+231−142

compare with master

unifiedsplit

Data/Aeson/Parser/Internal.hs+26−141 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+26−141

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

3636import Prelude ()

3737import Prelude.Compat

3838

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

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

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

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

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

4343import Data.ByteString.Internal (ByteString(..))

4444import Data.Char (chr)

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

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)

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

5647import qualified Data.Attoparsec.ByteString as A

5748import qualified Data.Attoparsec.Lazy as L

58−import qualified Data.Attoparsec.Zepto as Z

5949import qualified Data.ByteString as B

60−import qualified Data.ByteString.Internal as B

6150import qualified Data.ByteString.Lazy as L

62−import qualified Data.ByteString.Unsafe as B

6351import qualified Data.HashMap.Strict as H

52+import Data.Aeson.Parser.Unescape

6453

6554#if MIN_VERSION_ghc_prim(0,3,1)

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

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

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

6857#endif

6958

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

126115 w <- A.peekWord8'

127116 if w == CLOSE_CURLY

128117 then A.anyWord8 >> return H.empty

129− else loop H.empty

118+ else loop []

130119 where

131− loop m0 = do

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

122+ loop acc = do

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

133124 v <- val <* skipSpace

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

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

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

136127 if ch == COMMA

137− then skipSpace >> loop m

138− else return m

128+ then skipSpace >> loop acc'

129+ else return (H.fromList acc')

139130{-# INLINE objectValues #-}

140131

141132array_ :: Parser Value

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

152143 w <- A.peekWord8'

153144 if w == CLOSE_SQUARE

154145 then A.anyWord8 >> return Vector.empty

155− else loop []

146+ else loop [] 1

156147 where

157− loop acc = do

148+ loop acc !len = do

158149 v <- val <* skipSpace

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

160151 if ch == COMMA

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

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

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

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

163154{-# INLINE arrayValues #-}

164155

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

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

215206jstring_ :: Parser Text

216207{-# INLINE jstring_ #-}

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

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

219− _ <- A.anyWord8

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

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

210+ case unescapeText s of

226211 Right r -> return r

227212 Left err -> fail $ show err

228213 where

229214#if MIN_VERSION_ghc_prim(0,3,1)

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

231− startState = S 0# 0#

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

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

215+ startState = S 0#

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

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

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

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

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

220+ in Just (S a')

237221

238−data S = S Int# Int#

222+data S = S Int#

239223#else

240− isEscaped (S _ escaped) = escaped

241− startState = S False False

242− go (S a b) c

243− | a = Just (S False b)

224+ startState = False

225+ go a c

226+ | a = Just False

244227 | c == DOUBLE_QUOTE = Nothing

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

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

229+ in Just a'

247230 where backslash = BACKSLASH

248−

249−data S = S !Bool !Bool

250231#endif

251232

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−

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

314234decodeWith p to s =

315235 case L.parse p s of

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

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

374294jsonEOF' :: Parser Value

375295jsonEOF' = 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:

5252 examples/*.hs

5353 examples/Twitter/*.hs

5454 include/*.h

55+ cbits/*.c

5556

5657flag developer

5758 description: operate in developer mode

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

9192 Data.Aeson.Encoding.Builder

9293 Data.Aeson.Internal.Functions

9394 Data.Aeson.Parser.Internal

95+ Data.Aeson.Parser.Unescape

9496 Data.Aeson.Parser.Time

9597 Data.Aeson.Types.FromJSON

9698 Data.Aeson.Types.Generic

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

146148 ghc-options: -O2

147149

148150 include-dirs: include

151+ c-sources: cbits/unescape_string.c

149152

150153test-suite tests

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

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+