@@ -28,26 +28,31 @@ module Data.Aeson.Parser.Internal
2828 , eitherDecodeStrictWith
2929 ) where
3030
31−import Data.ByteString.Builder
32− (Builder, byteString, toLazyByteString, charUtf8, word8)
33−
3431import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)
32+import Control.Monad.IO.Class (liftIO)
3533import Data.Aeson.Types (Result(..), Value(..))
3634import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,
3735 skipSpace, string)
3836import Data.Bits ((.|.), shiftL)
39−import Data.ByteString (ByteString)
37+import Data.ByteString.Internal (ByteString(..))
4038import Data.Char (chr)
41−import Data.Monoid (mappend, mempty)
4239import Data.Text (Text)
4340import Data.Text.Encoding (decodeUtf8')
41+import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)
42+import Data.Text.Internal.Unsafe.Char (ord)
4443import Data.Vector as Vector (Vector, fromList)
4544import Data.Word (Word8)
45+import Foreign.ForeignPtr (withForeignPtr)
46+import Foreign.Ptr (minusPtr)
47+import Foreign.Ptr (Ptr, plusPtr)
48+import Foreign.Storable (poke)
49+import System.IO.Unsafe (unsafePerformIO)
4650import qualified Data.Attoparsec.ByteString as A
4751import qualified Data.Attoparsec.Lazy as L
4852import qualified Data.Attoparsec.Zepto as Z
4953import qualified Data.ByteString as B
5054import qualified Data.ByteString.Lazy as L
55+import qualified Data.ByteString.Internal as B
5156import qualified Data.ByteString.Unsafe as B
5257import qualified Data.HashMap.Strict as H
5358
@@ -198,7 +203,7 @@ jstring_ = {-# SCC "jstring_" #-} do
198203 else Just (c == BACKSLASH)
199204 _ <- A.word8 DOUBLE_QUOTE
200205 s1 <- if BACKSLASH `B.elem` s
201− then case Z.parse unescape s of
206+ then case unescape s of
202207 Right r -> return r
203208 Left err -> fail err
204209 else return s
@@ -209,9 +214,24 @@ jstring_ = {-# SCC "jstring_" #-} do
209214
210215{-# INLINE jstring_ #-}
211216
212−unescape :: Z.Parser ByteString
213−unescape = toByteString <$> go mempty where
214− go acc = do
217+unescape :: ByteString -> Either String ByteString
218+unescape s = unsafePerformIO $ do
219+ let len = B.length s
220+ fp <- B.mallocByteString len
221+ -- We perform no bounds checking when writing to the destination
222+ -- string, as unescaping always makes it shorter than the source.
223+ withForeignPtr fp $ \ptr -> do
224+ ret <- Z.parseT (go ptr) s
225+ case ret of
226+ Left err -> return (Left err)
227+ Right p -> do
228+ let newlen = p `minusPtr` ptr
229+ slop = len - newlen
230+ Right <$> if slop >= 128 && slop >= len `quot` 4
231+ then B.create newlen $ \np -> B.memcpy np ptr newlen
232+ else return (PS fp 0 newlen)
233+ where
234+ go ptr = do
215235 h <- Z.takeWhile (/=BACKSLASH)
216236 let rest = do
217237 start <- Z.take 2
@@ -222,29 +242,27 @@ unescape = toByteString <$> go mempty where
222242 _ -> 255
223243 if slash /= BACKSLASH || escape == 255
224244 then fail "invalid JSON escape sequence"
225− else do
226− let cont m = go (acc `mappend` byteString h `mappend` m)
227− {-# INLINE cont #-}
245+ else
228246 if t /= 117 -- 'u'
229− then cont (word8 (B.unsafeIndex mapping escape))
247+ then copy h ptr >>= word8 (B.unsafeIndex mapping escape) >>= go
230248 else do
231249 a <- hexQuad
232250 if a < 0xd800 || a > 0xdfff
233− then cont (charUtf8 (chr a))
251+ then copy h ptr >>= charUtf8 (chr a) >>= go
234252 else do
235253 b <- Z.string "\\u" *> hexQuad
236254 if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
237255 then let !c = ((a - 0xd800) `shiftL` 10) +
238256 (b - 0xdc00) + 0x10000
239− in cont (charUtf8 (chr c))
257+ in copy h ptr >>= charUtf8 (chr c) >>= go
240258 else fail "invalid UTF-16 surrogates"
241259 done <- Z.atEnd
242260 if done
243− then return (acc `mappend` byteString h)
261+ then copy h ptr
244262 else rest
245263 mapping = "\"\\/\n\t\b\r\f"
246264
247−hexQuad :: Z.Parser Int
265+hexQuad :: Z.ZeptoT IO Int
248266hexQuad = do
249267 s <- Z.take 4
250268 let hex n | w >= C_0 && w <= C_9 = w - C_0
@@ -321,6 +339,37 @@ jsonEOF = json <* skipSpace <* endOfInput
321339jsonEOF' :: Parser Value
322340jsonEOF' = json' <* skipSpace <* endOfInput
323341
324−toByteString :: Builder -> ByteString
325−toByteString = L.toStrict . toLazyByteString
326−{-# INLINE toByteString #-}
342+word8 :: Word8 -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
343+word8 w ptr = do
344+ liftIO $ poke ptr w
345+ return $! ptr `plusPtr` 1
346+
347+copy :: ByteString -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
348+copy (PS fp off len) ptr =
349+ liftIO . withForeignPtr fp $ \src -> do
350+ B.memcpy ptr (src `plusPtr` off) len
351+ return $! ptr `plusPtr` len
352+
353+charUtf8 :: Char -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)
354+charUtf8 ch ptr
355+ | ch < '\x80' = liftIO $ do
356+ poke ptr (fromIntegral (ord ch))
357+ return $! ptr `plusPtr` 1
358+ | ch < '\x800' = liftIO $ do
359+ let (a,b) = ord2 ch
360+ poke ptr a
361+ poke (ptr `plusPtr` 1) b
362+ return $! ptr `plusPtr` 2
363+ | ch < '\xffff' = liftIO $ do
364+ let (a,b,c) = ord3 ch
365+ poke ptr a
366+ poke (ptr `plusPtr` 1) b
367+ poke (ptr `plusPtr` 2) c
368+ return $! ptr `plusPtr` 3
369+ | otherwise = liftIO $ do
370+ let (a,b,c,d) = ord4 ch
371+ poke ptr a
372+ poke (ptr `plusPtr` 1) b
373+ poke (ptr `plusPtr` 2) c
374+ poke (ptr `plusPtr` 3) d
375+ return $! ptr `plusPtr` 4