{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.ByteString.Lazy.Encoding.Internal
  ( encode
  , encodeWith
  , decode
  , decodeWith
  ) where

import Control.Exception
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as BL
import Data.Char (ord)
import qualified Data.Text as T
import qualified Data.Text.Foreign as T
import qualified Data.Text.Lazy as TL
import Data.Word
import Foreign
import qualified Foreign.Concurrent as Conc
import Foreign.ForeignPtr (touchForeignPtr)
import Foreign.Ptr (nullPtr)
import qualified GHC.IO.Encoding as Enc
import GHC.IO.Buffer
import System.IO.Unsafe

-- | Encode a lazy 'TL.Text' into a lazy 'BL.ByteString' using a given 'Enc.TextEncoding'.
encode :: Enc.TextEncoding -> TL.Text -> BL.ByteString
encode :: TextEncoding -> Text -> ByteString
encode TextEncoding
enc = TextEncoding -> Int -> Int -> Text -> ByteString
encodeWith TextEncoding
enc Int
1024 Int
1024

encodeWith :: Enc.TextEncoding -> Int -> Int -> TL.Text -> BL.ByteString
encodeWith :: TextEncoding -> Int -> Int -> Text -> ByteString
encodeWith TextEncoding
enc Int
inBufSize Int
outBufSize = TextEncoding -> Int -> Int -> String -> ByteString
encodeStringWith TextEncoding
enc Int
inBufSize Int
outBufSize (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack

encodeStringWith :: Enc.TextEncoding -> Int -> Int -> String -> BL.ByteString
encodeStringWith :: TextEncoding -> Int -> Int -> String -> ByteString
encodeStringWith Enc.TextEncoding{ String
IO (TextEncoder estate)
IO (TextDecoder dstate)
textEncodingName :: TextEncoding -> String
mkTextDecoder :: ()
mkTextEncoder :: ()
mkTextEncoder :: IO (TextEncoder estate)
mkTextDecoder :: IO (TextDecoder dstate)
textEncodingName :: String
.. } Int
inBufSize Int
outBufSize String
s = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ IO [ByteString] -> [ByteString]
forall a. IO a -> a
unsafePerformIO (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ do
  Enc.BufferCodec{ IO estate
IO ()
estate -> IO ()
Buffer CharBufElem
-> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8)
CodeBuffer CharBufElem Word8
encode :: forall from to state.
BufferCodec from to state -> CodeBuffer from to
recover :: forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
close :: forall from to state. BufferCodec from to state -> IO ()
getState :: forall from to state. BufferCodec from to state -> IO state
setState :: forall from to state. BufferCodec from to state -> state -> IO ()
setState :: estate -> IO ()
getState :: IO estate
close :: IO ()
recover :: Buffer CharBufElem
-> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8)
encode :: CodeBuffer CharBufElem Word8
.. } <- IO (TextEncoder estate)
mkTextEncoder
  ForeignPtr Any
fp <- Ptr Any -> IO () -> IO (ForeignPtr Any)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Conc.newForeignPtr Ptr Any
forall a. Ptr a
nullPtr IO ()
close

  let fillInBuf :: String -> CharBuffer -> IO (String, CharBuffer)
      fillInBuf :: String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
fillInBuf String
s Buffer CharBufElem
buf
        | Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CharBufElem
buf = String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
go String
s Buffer CharBufElem
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
        | Bool
otherwise = String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
go String
s Buffer CharBufElem
buf
        where
          go :: String -> CharBuffer -> IO (String, CharBuffer)
          go :: String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
go [] Buffer CharBufElem
buf = (String, Buffer CharBufElem) -> IO (String, Buffer CharBufElem)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Buffer CharBufElem
buf)
          go s :: String
s@(CharBufElem
c : String
cs) buf :: Buffer CharBufElem
buf@Buffer{ bufR :: forall e. Buffer e -> Int
bufR = Int
r, bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw = RawBuffer CharBufElem
iraw}
            | Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isFullCharBuffer Buffer CharBufElem
buf = (String, Buffer CharBufElem) -> IO (String, Buffer CharBufElem)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
s, Buffer CharBufElem
buf)
            | Bool
otherwise = do
                Int
r' <- RawBuffer CharBufElem -> Int -> CharBufElem -> IO Int
writeCharBuf RawBuffer CharBufElem
iraw Int
r CharBufElem
c
                String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
go String
cs Buffer CharBufElem
buf{ bufR :: Int
bufR = Int
r' }

      flushOutBuf :: Buffer Word8 -> IO ([B.ByteString], Buffer Word8)
      flushOutBuf :: Buffer Word8 -> IO ([ByteString], Buffer Word8)
flushOutBuf Buffer Word8
buf
        | Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
buf = ([ByteString], Buffer Word8) -> IO ([ByteString], Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Buffer Word8
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 })
        | Bool
otherwise = do
            Buffer Word8
-> (Ptr Word8 -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
buf ((Ptr Word8 -> IO ([ByteString], Buffer Word8))
 -> IO ([ByteString], Buffer Word8))
-> (Ptr Word8 -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
              ByteString
b <- CStringLen -> IO ByteString
B.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p, Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
buf)
              ([ByteString], Buffer Word8) -> IO ([ByteString], Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString
b], Buffer Word8
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 })

      loop :: String -> CharBuffer -> Buffer Word8 -> IO [B.ByteString]
      loop :: String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s Buffer CharBufElem
inBuf Buffer Word8
outBuf = do
        (String
s', Buffer CharBufElem
inBuf1) <- String -> Buffer CharBufElem -> IO (String, Buffer CharBufElem)
fillInBuf String
s Buffer CharBufElem
inBuf
        if Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CharBufElem
inBuf1 then do
          Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          ([ByteString]
m, Buffer Word8
_outBuf') <- Buffer Word8 -> IO ([ByteString], Buffer Word8)
flushOutBuf Buffer Word8
outBuf
          ForeignPtr Any -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr Any
fp
          [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString]
m
        else do
          (CodingProgress
ret, Buffer CharBufElem
inBuf2, Buffer Word8
outBuf2) <- CodeBuffer CharBufElem Word8
encode Buffer CharBufElem
inBuf1 Buffer Word8
outBuf
          case CodingProgress
ret of
            CodingProgress
Enc.InputUnderflow -> do
              if Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isFullCharBuffer Buffer CharBufElem
inBuf2 Bool -> Bool -> Bool
&& Bool -> Bool
not (Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CharBufElem
inBuf2) then do
                RawBuffer CharBufElem -> (Ptr CharBufElem -> IO ()) -> IO ()
forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a
withRawBuffer (Buffer CharBufElem -> RawBuffer CharBufElem
forall e. Buffer e -> RawBuffer e
bufRaw Buffer CharBufElem
inBuf2) ((Ptr CharBufElem -> IO ()) -> IO ())
-> (Ptr CharBufElem -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CharBufElem
p -> do
                  Ptr CharBufElem -> Ptr CharBufElem -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray Ptr CharBufElem
p (Ptr CharBufElem
p Ptr CharBufElem -> Int -> Ptr CharBufElem
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufL Buffer CharBufElem
inBuf2) (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferElems Buffer CharBufElem
inBuf2)
                String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s' Buffer CharBufElem
inBuf2{ bufL :: Int
bufL = Int
0, bufR :: Int
bufR = Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferElems Buffer CharBufElem
inBuf2 } Buffer Word8
outBuf2
              else do
                String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s' Buffer CharBufElem
inBuf2 Buffer Word8
outBuf2
            CodingProgress
Enc.OutputUnderflow -> do
              ([ByteString]
b, Buffer Word8
outBuf3) <- Buffer Word8 -> IO ([ByteString], Buffer Word8)
flushOutBuf Buffer Word8
outBuf2
              [ByteString]
bs <- IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s' Buffer CharBufElem
inBuf2 Buffer Word8
outBuf3
              [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
b [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
bs
            CodingProgress
Enc.InvalidSequence -> do
              -- recover assumes that to buffer has at least one element of free space.
              if Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isFullBuffer Buffer Word8
outBuf2 then do
                ([ByteString]
b, Buffer Word8
outBuf3) <- Buffer Word8 -> IO ([ByteString], Buffer Word8)
flushOutBuf Buffer Word8
outBuf2
                (Buffer CharBufElem
inBuf4, Buffer Word8
outBuf4) <- Buffer CharBufElem
-> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8)
recover Buffer CharBufElem
inBuf2 Buffer Word8
outBuf3
                [ByteString]
bs <- IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s' Buffer CharBufElem
inBuf4 Buffer Word8
outBuf4
                [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
b [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
bs
              else do
                (Buffer CharBufElem
inBuf3, Buffer Word8
outBuf3) <- Buffer CharBufElem
-> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8)
recover Buffer CharBufElem
inBuf2 Buffer Word8
outBuf2
                String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s' Buffer CharBufElem
inBuf3 Buffer Word8
outBuf3

  Buffer CharBufElem
inBuf <- Int -> BufferState -> IO (Buffer CharBufElem)
newCharBuffer Int
inBufSize BufferState
ReadBuffer
  Buffer Word8
outBuf <- Int -> BufferState -> IO (Buffer Word8)
newByteBuffer Int
outBufSize BufferState
WriteBuffer
  String -> Buffer CharBufElem -> Buffer Word8 -> IO [ByteString]
loop String
s Buffer CharBufElem
inBuf Buffer Word8
outBuf


-- | Decode a lazy 'BL.ByteString' to a lazy 'TL.Text' using a given 'Enc.TextEncoding'.
decode :: Enc.TextEncoding -> BL.ByteString -> TL.Text
decode :: TextEncoding -> ByteString -> Text
decode TextEncoding
enc ByteString
b = TextEncoding -> Int -> Int -> ByteString -> Text
decodeWith TextEncoding
enc Int
1024 Int
1024 ByteString
b

decodeWith :: Enc.TextEncoding -> Int -> Int -> BL.ByteString -> TL.Text
decodeWith :: TextEncoding -> Int -> Int -> ByteString -> Text
decodeWith Enc.TextEncoding{ String
IO (TextEncoder estate)
IO (TextDecoder dstate)
mkTextEncoder :: IO (TextEncoder estate)
mkTextDecoder :: IO (TextDecoder dstate)
textEncodingName :: String
textEncodingName :: TextEncoding -> String
mkTextDecoder :: ()
mkTextEncoder :: ()
.. } Int
inBufSize Int
outBufSize ByteString
b = [Text] -> Text
TL.fromChunks ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ IO [Text] -> [Text]
forall a. IO a -> a
unsafePerformIO (IO [Text] -> [Text]) -> IO [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
  Enc.BufferCodec{ IO dstate
IO ()
dstate -> IO ()
Buffer Word8
-> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem)
CodeBuffer Word8 CharBufElem
setState :: dstate -> IO ()
getState :: IO dstate
close :: IO ()
recover :: Buffer Word8
-> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem)
encode :: CodeBuffer Word8 CharBufElem
encode :: forall from to state.
BufferCodec from to state -> CodeBuffer from to
recover :: forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
close :: forall from to state. BufferCodec from to state -> IO ()
getState :: forall from to state. BufferCodec from to state -> IO state
setState :: forall from to state. BufferCodec from to state -> state -> IO ()
.. } <- IO (TextDecoder dstate)
mkTextDecoder
  ForeignPtr Any
fp <- Ptr Any -> IO () -> IO (ForeignPtr Any)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Conc.newForeignPtr Ptr Any
forall a. Ptr a
nullPtr IO ()
close

  let fillInBuf :: [B.ByteString] -> Buffer Word8 -> IO ([B.ByteString], Buffer Word8)
      fillInBuf :: [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
fillInBuf [ByteString]
bs Buffer Word8
buf
        | Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
buf = [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go [ByteString]
bs Buffer Word8
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
        | Bool
otherwise = [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go [ByteString]
bs Buffer Word8
buf
        where
          go :: [B.ByteString] -> Buffer Word8 -> IO ([B.ByteString], Buffer Word8)
          go :: [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go [] Buffer Word8
buf = ([ByteString], Buffer Word8) -> IO ([ByteString], Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Buffer Word8
buf)
          go bbs :: [ByteString]
bbs@(ByteString
b : [ByteString]
bs) Buffer Word8
buf
            | Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isFullBuffer Buffer Word8
buf = ([ByteString], Buffer Word8) -> IO ([ByteString], Buffer Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString]
bbs, Buffer Word8
buf)
            | ByteString -> Bool
B.null ByteString
b = [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go [ByteString]
bs Buffer Word8
buf
            | Bool
otherwise = do
                ByteString
-> (Ptr CChar -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.unsafeUseAsCString ByteString
b ((Ptr CChar -> IO ([ByteString], Buffer Word8))
 -> IO ([ByteString], Buffer Word8))
-> (Ptr CChar -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
p -> do
                  Buffer Word8
-> (Ptr Word8 -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
buf ((Ptr Word8 -> IO ([ByteString], Buffer Word8))
 -> IO ([ByteString], Buffer Word8))
-> (Ptr Word8 -> IO ([ByteString], Buffer Word8))
-> IO ([ByteString], Buffer Word8)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
q -> do
                    if ByteString -> Int
B.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
buf then do
                      Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
moveBytes (Ptr Word8
q Ptr Word8 -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer Word8 -> Int
forall e. Buffer e -> Int
bufR Buffer Word8
buf) Ptr CChar
p (ByteString -> Int
B.length ByteString
b)
                      [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go [ByteString]
bs Buffer Word8
buf{ bufR :: Int
bufR = Buffer Word8 -> Int
forall e. Buffer e -> Int
bufR Buffer Word8
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
b }
                    else do
                      Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
moveBytes (Ptr Word8
q Ptr Word8 -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer Word8 -> Int
forall e. Buffer e -> Int
bufR Buffer Word8
buf) Ptr CChar
p (Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
buf)
                      [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
go (Int -> ByteString -> ByteString
B.drop (Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
buf) ByteString
b ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
bs) Buffer Word8
buf{ bufR :: Int
bufR = Buffer Word8 -> Int
forall e. Buffer e -> Int
bufR Buffer Word8
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
buf }

#if MIN_VERSION_text(2,0,0)
      flushOutBuf :: CharBuffer -> ForeignPtr Word8 -> IO ([T.Text], CharBuffer)
      flushOutBuf buf workspace
        | isEmptyBuffer buf = return ([], buf{ bufL=0, bufR=0 })
        | otherwise =
            withForeignPtr workspace $ \workspace' ->
            withBuffer buf $ \p -> do
              let f !i !j
                    | bufR buf <= i = return j
                    | otherwise = do
                        (c, i') <- readCharBufPtr (castPtr p) i
                        j' <- writeUTF8 workspace' j c
                        f i' j'
              n <- f (bufL buf) 0
              t <- T.fromPtr workspace' (fromIntegral n)
              return ([t], buf{ bufL=0, bufR=0 })
#else
      flushOutBuf :: CharBuffer -> ForeignPtr Word16 -> IO ([T.Text], CharBuffer)
      flushOutBuf :: Buffer CharBufElem
-> ForeignPtr Word16 -> IO ([Text], Buffer CharBufElem)
flushOutBuf Buffer CharBufElem
buf ForeignPtr Word16
workspace
        | Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer CharBufElem
buf = ([Text], Buffer CharBufElem) -> IO ([Text], Buffer CharBufElem)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Buffer CharBufElem
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 })
        | Int
charSizeInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
2 = do
            Buffer CharBufElem
-> (Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer CharBufElem
buf ((Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
 -> IO ([Text], Buffer CharBufElem))
-> (Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall a b. (a -> b) -> a -> b
$ \Ptr CharBufElem
p -> do
              let p' :: Ptr Word16
                  p' :: Ptr Word16
p' = Ptr CharBufElem -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr CharBufElem
p
              Text
t <- Ptr Word16 -> I16 -> IO Text
T.fromPtr (Ptr Word16
p' Ptr Word16 -> Int -> Ptr Word16
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufL Buffer CharBufElem
buf) (Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufferElems Buffer CharBufElem
buf))
              ([Text], Buffer CharBufElem) -> IO ([Text], Buffer CharBufElem)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text
t], Buffer CharBufElem
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 })
        | Bool
otherwise =
            ForeignPtr Word16
-> (Ptr Word16 -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a
withForeignPtr ForeignPtr Word16
workspace ((Ptr Word16 -> IO ([Text], Buffer CharBufElem))
 -> IO ([Text], Buffer CharBufElem))
-> (Ptr Word16 -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
workspace' ->
            Buffer CharBufElem
-> (Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer CharBufElem
buf ((Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
 -> IO ([Text], Buffer CharBufElem))
-> (Ptr CharBufElem -> IO ([Text], Buffer CharBufElem))
-> IO ([Text], Buffer CharBufElem)
forall a b. (a -> b) -> a -> b
$ \Ptr CharBufElem
p -> do
              let p' :: Ptr Char
                  p' :: Ptr CharBufElem
p' = Ptr CharBufElem -> Ptr CharBufElem
forall a b. Ptr a -> Ptr b
castPtr Ptr CharBufElem
p
                  f :: Int -> Int -> IO Int
f !Int
i !Int
j
                    | Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufR Buffer CharBufElem
buf Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
j
                    | Bool
otherwise = do
                        Int
c <- (CharBufElem -> Int) -> IO CharBufElem -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CharBufElem -> Int
forall a. Enum a => a -> Int
fromEnum (IO CharBufElem -> IO Int) -> IO CharBufElem -> IO Int
forall a b. (a -> b) -> a -> b
$ Ptr CharBufElem -> Int -> IO CharBufElem
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CharBufElem
p' Int
i
                        if Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 then do
                          Ptr Word16 -> Int -> Word16 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word16
workspace' Int
j (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c)
                          Int -> Int -> IO Int
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                        else do
                          let c' :: Int
c' = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x10000
                          Ptr Word16 -> Int -> Word16 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word16
workspace' Int
j (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
0x400 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0xd800))
                          Ptr Word16 -> Int -> Word16 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word16
workspace' (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
0x400 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0xdc00))
                          Int -> Int -> IO Int
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
              Int
n <- Int -> Int -> IO Int
f (Buffer CharBufElem -> Int
forall e. Buffer e -> Int
bufL Buffer CharBufElem
buf) Int
0
              Text
t <- Ptr Word16 -> I16 -> IO Text
T.fromPtr Ptr Word16
workspace' (Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
              ([Text], Buffer CharBufElem) -> IO ([Text], Buffer CharBufElem)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text
t], Buffer CharBufElem
buf{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 })
#endif

#if MIN_VERSION_text(2,0,0)
      loop :: [B.ByteString] -> Buffer Word8 -> CharBuffer -> ForeignPtr Word8 -> IO [T.Text]
#else
      loop :: [B.ByteString] -> Buffer Word8 -> CharBuffer -> ForeignPtr Word16 -> IO [T.Text]
#endif
      loop :: [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs Buffer Word8
inBuf Buffer CharBufElem
outBuf ForeignPtr Word16
workspace = do
        ([ByteString]
bs', Buffer Word8
inBuf1) <- [ByteString] -> Buffer Word8 -> IO ([ByteString], Buffer Word8)
fillInBuf [ByteString]
bs Buffer Word8
inBuf
        if Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
inBuf1 then do
          Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
bs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          ([Text]
m, Buffer CharBufElem
_outBuf') <- Buffer CharBufElem
-> ForeignPtr Word16 -> IO ([Text], Buffer CharBufElem)
flushOutBuf Buffer CharBufElem
outBuf ForeignPtr Word16
workspace
          ForeignPtr Any -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr Any
fp
          [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
m
        else do
          (CodingProgress
ret, Buffer Word8
inBuf2, Buffer CharBufElem
outBuf2) <- CodeBuffer Word8 CharBufElem
encode Buffer Word8
inBuf1 Buffer CharBufElem
outBuf
          case CodingProgress
ret of
            CodingProgress
Enc.InputUnderflow -> do
              if Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isFullBuffer Buffer Word8
inBuf2 Bool -> Bool -> Bool
&& Bool -> Bool
not (Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
inBuf2) then do
                Buffer Word8
inBuf3 <- Buffer Word8 -> IO (Buffer Word8)
slideContents Buffer Word8
inBuf2
                [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs' Buffer Word8
inBuf3 Buffer CharBufElem
outBuf2 ForeignPtr Word16
workspace
              else do
                [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs' Buffer Word8
inBuf2 Buffer CharBufElem
outBuf2 ForeignPtr Word16
workspace
            CodingProgress
Enc.OutputUnderflow -> do
              ([Text]
t, Buffer CharBufElem
outBuf3) <- Buffer CharBufElem
-> ForeignPtr Word16 -> IO ([Text], Buffer CharBufElem)
flushOutBuf Buffer CharBufElem
outBuf2 ForeignPtr Word16
workspace
              [Text]
ts <- IO [Text] -> IO [Text]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Text] -> IO [Text]) -> IO [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs' Buffer Word8
inBuf2 Buffer CharBufElem
outBuf3 ForeignPtr Word16
workspace
              [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts
            CodingProgress
Enc.InvalidSequence -> do
              -- recover assumes that to buffer has at least one element of free space.
              if Buffer CharBufElem -> Bool
forall e. Buffer e -> Bool
isFullCharBuffer Buffer CharBufElem
outBuf2 then do
                ([Text]
t, Buffer CharBufElem
outBuf3) <- Buffer CharBufElem
-> ForeignPtr Word16 -> IO ([Text], Buffer CharBufElem)
flushOutBuf Buffer CharBufElem
outBuf2 ForeignPtr Word16
workspace
                (Buffer Word8
inBuf4, Buffer CharBufElem
outBuf4) <- Buffer Word8
-> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem)
recover Buffer Word8
inBuf2 Buffer CharBufElem
outBuf3
                [Text]
ts <- IO [Text] -> IO [Text]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Text] -> IO [Text]) -> IO [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs' Buffer Word8
inBuf4 Buffer CharBufElem
outBuf4 ForeignPtr Word16
workspace
                [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts
              else do
                (Buffer Word8
inBuf3, Buffer CharBufElem
outBuf3) <- Buffer Word8
-> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem)
recover Buffer Word8
inBuf2 Buffer CharBufElem
outBuf2
                [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop [ByteString]
bs' Buffer Word8
inBuf3 Buffer CharBufElem
outBuf3 ForeignPtr Word16
workspace

  Buffer Word8
inBuf <- Int -> BufferState -> IO (Buffer Word8)
newByteBuffer Int
inBufSize BufferState
ReadBuffer
  Buffer CharBufElem
outBuf <- Int -> BufferState -> IO (Buffer CharBufElem)
newCharBuffer Int
outBufSize BufferState
WriteBuffer
#if MIN_VERSION_text(2,0,0)
  workspace <- mallocForeignPtrArray (outBufSize * 4)
#else
  ForeignPtr Word16
workspace <- if Int
charSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 then Ptr Word16 -> IO (ForeignPtr Word16)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Word16
forall a. Ptr a
nullPtr else Int -> IO (ForeignPtr Word16)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
outBufSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
#endif
  [ByteString]
-> Buffer Word8
-> Buffer CharBufElem
-> ForeignPtr Word16
-> IO [Text]
loop (ByteString -> [ByteString]
BL.toChunks ByteString
b) Buffer Word8
inBuf Buffer CharBufElem
outBuf ForeignPtr Word16
workspace


#if MIN_VERSION_text(2,0,0)

writeUTF8 :: Ptr Word8 -> Int -> Char -> IO Int
writeUTF8 p i c = do
  let x = ord c
  if x <= 0x7F then do
    pokeElemOff p i (fromIntegral x)
    return $! i+1
  else if x <= 0x07FF then do
    let (c1,c2) = ord2 c
    pokeElemOff p i c1
    pokeElemOff p (i+1) c2
    return $! i+2
  else if x <= 0xFFFF then do
    let (c1,c2,c3) = ord3 c
    pokeElemOff p i c1
    pokeElemOff p (i+1) c2
    pokeElemOff p (i+2) c3
    return $! i+3
  else do
    let (c1,c2,c3,c4) = ord4 c
    pokeElemOff p i c1
    pokeElemOff p (i+1) c2
    pokeElemOff p (i+2) c3
    pokeElemOff p (i+3) c4
    return $! i+4

-- -----------------------------------------------------------------------------
-- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8

ord2   :: Char -> (Word8,Word8)
ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
      x2 = fromIntegral $ (n .&. 0x3F)   + 0x80

ord3   :: Char -> (Word8,Word8,Word8)
ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
      x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
      x3 = fromIntegral $ (n .&. 0x3F) + 0x80

ord4   :: Char -> (Word8,Word8,Word8,Word8)
ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
    where
      n  = ord c
      x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
      x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
      x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
      x4 = fromIntegral $ (n .&. 0x3F) + 0x80

#endif