1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
module Data.Aeson.Parser.UnescapeFFI
(
unescapeText
) where
import Control.Exception (evaluate, throw, try)
import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
import Data.ByteString as B
import Data.ByteString.Internal as B
import Data.Text.Encoding.Error (UnicodeException (..))
import Data.Text.Internal (Text (..))
import Data.Text.Internal.Private (runText)
import Data.Text.Unsafe (unsafeDupablePerformIO)
import Data.Word (Word8)
import Foreign.C.Types (CInt (..), CSize (..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.Storable (peek)
import GHC.Base (MutableByteArray#)
import qualified Data.Text.Array as A
foreign import ccall unsafe "_js_decode_string" c_js_decode
:: MutableByteArray# s -> Ptr CSize
-> Ptr Word8 -> Ptr Word8 -> IO CInt
unescapeText' :: ByteString -> Text
#if MIN_VERSION_bytestring(0,11,0)
unescapeText' (BS fp len) = runText $ \done -> do
let off = 0
#else
unescapeText' (PS fp off len) = runText $ \done -> do
#endif
let go dest = withForeignPtr fp $ \ptr ->
with (0::CSize) $ \destOffPtr -> do
let end = ptr `plusPtr` (off + len)
loop curPtr = do
res <- c_js_decode (A.maBA dest) destOffPtr curPtr end
case res of
0 -> do
n <- peek destOffPtr
unsafeSTToIO (done dest (fromIntegral n))
_ ->
throw (DecodeError desc Nothing)
loop (ptr `plusPtr` off)
(unsafeIOToST . go) =<< A.new len
where
desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
{-# INLINE unescapeText' #-}
unescapeText :: ByteString -> Either UnicodeException Text
unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'
{-# INLINE unescapeText #-}
|
