module Data.Text.Encoding
(
decodeASCII
, decodeLatin1
, decodeUtf8
, decodeUtf16LE
, decodeUtf16BE
, decodeUtf32LE
, decodeUtf32BE
, decodeUtf8'
, decodeUtf8With
, decodeUtf16LEWith
, decodeUtf16BEWith
, decodeUtf32LEWith
, decodeUtf32BEWith
, streamDecodeUtf8
, streamDecodeUtf8With
, Decoding(..)
, encodeUtf8
, encodeUtf16LE
, encodeUtf16BE
, encodeUtf32LE
, encodeUtf32BE
, encodeUtf8Builder
, encodeUtf8BuilderEscaped
) where
import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
import Control.Exception (evaluate, try, throwIO, ErrorCall(ErrorCall))
import Control.Monad.ST (runST)
import Data.Bits ((.&.))
import Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.Foldable (traverse_)
import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
import Data.Text.Internal (Text(..), safe, text)
import Data.Text.Internal.Functions
import Data.Text.Internal.Private (runText)
import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
import Data.Text.Internal.Unsafe.Shift (shiftR)
import Data.Text.Show ()
import Data.Text.Unsafe (unsafeDupablePerformIO)
import Data.Word (Word8, Word16, Word32)
import Foreign.C.Types (CSize(CSize))
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
import Foreign.Storable (Storable, peek, poke)
import GHC.Base (ByteArray#, MutableByteArray#)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Internal as B hiding (empty, append)
import qualified Data.ByteString.Builder.Prim as BP
import qualified Data.ByteString.Builder.Prim.Internal as BP
import qualified Data.Text.Array as A
import qualified Data.Text.Internal.Encoding.Fusion as E
import qualified Data.Text.Internal.Encoding.Utf16 as U16
import qualified Data.Text.Internal.Fusion as F
import Data.Text.Internal.ByteStringCompat
#if defined(ASSERTS)
import GHC.Stack (HasCallStack)
#endif
#include "text_cbits.h"
decodeASCII :: ByteString -> Text
decodeASCII = decodeUtf8
decodeLatin1 ::
#if defined(ASSERTS)
HasCallStack =>
#endif
ByteString -> Text
decodeLatin1 bs = withBS bs aux where
aux fp len = text a 0 len
where
a = A.run (A.new len >>= unsafeIOToST . go)
go dest = unsafeWithForeignPtr fp $ \ptr -> do
c_decode_latin1 (A.maBA dest) ptr (ptr `plusPtr` len)
return dest
decodeUtf8With ::
#if defined(ASSERTS)
HasCallStack =>
#endif
OnDecodeError -> ByteString -> Text
decodeUtf8With onErr bs = withBS bs aux
where
aux fp len = runText $ \done -> do
let go dest = unsafeWithForeignPtr fp $ \ptr ->
with (0::CSize) $ \destOffPtr -> do
let end = ptr `plusPtr` len
loop curPtr = do
curPtr' <- c_decode_utf8 (A.maBA dest) destOffPtr curPtr end
if curPtr' == end
then do
n <- peek destOffPtr
unsafeSTToIO (done dest (cSizeToInt n))
else do
x <- peek curPtr'
case onErr desc (Just x) of
Nothing -> loop $ curPtr' `plusPtr` 1
Just c
| c > '\xFFFF' -> throwUnsupportedReplChar
| otherwise -> do
destOff <- peek destOffPtr
w <- unsafeSTToIO $
unsafeWrite dest (cSizeToInt destOff)
(safe c)
poke destOffPtr (destOff + intToCSize w)
loop $ curPtr' `plusPtr` 1
loop ptr
(unsafeIOToST . go) =<< A.new len
where
desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
throwUnsupportedReplChar = throwIO $
ErrorCall "decodeUtf8With: non-BMP replacement characters not supported"
data Decoding = Some Text ByteString (ByteString -> Decoding)
instance Show Decoding where
showsPrec d (Some t bs _) = showParen (d > prec) $
showString "Some " . showsPrec prec' t .
showChar ' ' . showsPrec prec' bs .
showString " _"
where prec = 10; prec' = prec + 1
newtype CodePoint = CodePoint Word32 deriving (Eq, Show, Num, Storable)
newtype DecoderState = DecoderState Word32 deriving (Eq, Show, Num, Storable)
streamDecodeUtf8 ::
#if defined(ASSERTS)
HasCallStack =>
#endif
ByteString -> Decoding
streamDecodeUtf8 = streamDecodeUtf8With strictDecode
streamDecodeUtf8With ::
#if defined(ASSERTS)
HasCallStack =>
#endif
OnDecodeError -> ByteString -> Decoding
streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
where
decodeChunk :: ByteString -> CodePoint -> DecoderState -> ByteString
-> Decoding
decodeChunk undecoded0 codepoint0 state0 bs = withBS bs aux where
aux fp len = runST $ (unsafeIOToST . decodeChunkToBuffer) =<< A.new (len+3)
where
decodeChunkToBuffer :: A.MArray s -> IO Decoding
decodeChunkToBuffer dest = unsafeWithForeignPtr fp $ \ptr ->
with (0::CSize) $ \destOffPtr ->
with codepoint0 $ \codepointPtr ->
with state0 $ \statePtr ->
with nullPtr $ \curPtrPtr ->
let end = ptr `plusPtr` len
loop curPtr = do
prevState <- peek statePtr
poke curPtrPtr curPtr
lastPtr <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
curPtrPtr end codepointPtr statePtr
state <- peek statePtr
case state of
UTF8_REJECT -> do
poke statePtr 0
let skipByte x = case onErr desc (Just x) of
Nothing -> return ()
Just c -> do
destOff <- peek destOffPtr
w <- unsafeSTToIO $
unsafeWrite dest (cSizeToInt destOff) (safe c)
poke destOffPtr (destOff + intToCSize w)
if ptr == lastPtr && prevState /= UTF8_ACCEPT then do
traverse_ skipByte (B.unpack undecoded0 )
loop lastPtr
else do
peek lastPtr >>= skipByte
loop (lastPtr `plusPtr` 1)
_ -> do
n <- peek destOffPtr
codepoint <- peek codepointPtr
chunkText <- unsafeSTToIO $ do
arr <- A.unsafeFreeze dest
return $! text arr 0 (cSizeToInt n)
let left = lastPtr `minusPtr` ptr
!undecoded = case state of
UTF8_ACCEPT -> B.empty
_ | left == 0 && prevState /= UTF8_ACCEPT -> B.append undecoded0 bs
| otherwise -> B.drop left bs
return $ Some chunkText undecoded
(decodeChunk undecoded codepoint state)
in loop ptr
desc = "Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream"
decodeUtf8 :: ByteString -> Text
decodeUtf8 = decodeUtf8With strictDecode
decodeUtf8' ::
#if defined(ASSERTS)
HasCallStack =>
#endif
ByteString -> Either UnicodeException Text
decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode
encodeUtf8Builder :: Text -> B.Builder
encodeUtf8Builder = encodeUtf8BuilderEscaped (BP.liftFixedToBounded BP.word8)
encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder
encodeUtf8BuilderEscaped be =
\txt -> B.builder (mkBuildstep txt)
where
bound = max 4 $ BP.sizeBound be
mkBuildstep (Text arr off len) !k =
outerLoop off
where
iend = off + len
outerLoop !i0 !br@(B.BufferRange op0 ope)
| i0 >= iend = k br
| outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
| otherwise = return $ B.bufferFull bound op0 (outerLoop i0)
where
outRemaining = (ope `minusPtr` op0) `div` bound
inpRemaining = iend i0
goPartial !iendTmp = go i0 op0
where
go !i !op
| i < iendTmp = case A.unsafeIndex arr i of
w | w <= 0x7F -> do
BP.runB be (word16ToWord8 w) op >>= go (i + 1)
| w <= 0x7FF -> do
poke8 @Word16 0 $ (w `shiftR` 6) + 0xC0
poke8 @Word16 1 $ (w .&. 0x3f) + 0x80
go (i + 1) (op `plusPtr` 2)
| 0xD800 <= w && w <= 0xDBFF -> do
let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))
poke8 @Int 0 $ (c `shiftR` 18) + 0xF0
poke8 @Int 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80
poke8 @Int 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80
poke8 @Int 3 $ (c .&. 0x3F) + 0x80
go (i + 2) (op `plusPtr` 4)
| otherwise -> do
poke8 @Word16 0 $ (w `shiftR` 12) + 0xE0
poke8 @Word16 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80
poke8 @Word16 2 $ (w .&. 0x3F) + 0x80
go (i + 1) (op `plusPtr` 3)
| otherwise =
outerLoop i (B.BufferRange op ope)
where
poke8 :: Integral a => Int -> a -> IO ()
poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)
encodeUtf8 :: Text -> ByteString
encodeUtf8 (Text arr off len)
| len == 0 = B.empty
| otherwise = unsafeDupablePerformIO $ do
fp <- B.mallocByteString (len*3)
unsafeWithForeignPtr fp $ \ptr ->
with ptr $ \destPtr -> do
c_encode_utf8 destPtr (A.aBA arr) (intToCSize off) (intToCSize len)
newDest <- peek destPtr
let utf8len = newDest `minusPtr` ptr
if utf8len >= len `shiftR` 1
then return (mkBS fp utf8len)
else do
fp' <- B.mallocByteString utf8len
unsafeWithForeignPtr fp' $ \ptr' -> do
B.memcpy ptr' ptr utf8len
return (mkBS fp' utf8len)
decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
decodeUtf16LEWith onErr bs = F.unstream (E.streamUtf16LE onErr bs)
decodeUtf16LE :: ByteString -> Text
decodeUtf16LE = decodeUtf16LEWith strictDecode
decodeUtf16BEWith :: OnDecodeError -> ByteString -> Text
decodeUtf16BEWith onErr bs = F.unstream (E.streamUtf16BE onErr bs)
decodeUtf16BE :: ByteString -> Text
decodeUtf16BE = decodeUtf16BEWith strictDecode
encodeUtf16LE :: Text -> ByteString
encodeUtf16LE txt = E.unstream (E.restreamUtf16LE (F.stream txt))
encodeUtf16BE :: Text -> ByteString
encodeUtf16BE txt = E.unstream (E.restreamUtf16BE (F.stream txt))
decodeUtf32LEWith :: OnDecodeError -> ByteString -> Text
decodeUtf32LEWith onErr bs = F.unstream (E.streamUtf32LE onErr bs)
decodeUtf32LE :: ByteString -> Text
decodeUtf32LE = decodeUtf32LEWith strictDecode
decodeUtf32BEWith :: OnDecodeError -> ByteString -> Text
decodeUtf32BEWith onErr bs = F.unstream (E.streamUtf32BE onErr bs)
decodeUtf32BE :: ByteString -> Text
decodeUtf32BE = decodeUtf32BEWith strictDecode
encodeUtf32LE :: Text -> ByteString
encodeUtf32LE txt = E.unstream (E.restreamUtf32LE (F.stream txt))
encodeUtf32BE :: Text -> ByteString
encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
cSizeToInt :: CSize -> Int
cSizeToInt = fromIntegral
intToCSize :: Int -> CSize
intToCSize = fromIntegral
word16ToWord8 :: Word16 -> Word8
word16ToWord8 = fromIntegral
foreign import ccall unsafe "_hs_text_decode_utf8" c_decode_utf8
:: MutableByteArray# s -> Ptr CSize
-> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)
foreign import ccall unsafe "_hs_text_decode_utf8_state" c_decode_utf8_with_state
:: MutableByteArray# s -> Ptr CSize
-> Ptr (Ptr Word8) -> Ptr Word8
-> Ptr CodePoint -> Ptr DecoderState -> IO (Ptr Word8)
foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
:: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
:: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()