module GF.Text.Coding where import qualified Data.ByteString as BS import Data.ByteString.Internal import GHC.IO import GHC.IO.Buffer import GHC.IO.Encoding import GHC.IO.Exception import Control.Monad encodeUnicode :: TextEncoding -> String -> ByteString encodeUnicode :: TextEncoding -> String -> ByteString encodeUnicode TextEncoding enc String s = IO ByteString -> ByteString forall a. IO a -> a unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString forall a b. (a -> b) -> a -> b $ do let len :: Int len = String -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length String s CharBuffer cbuf0 <- Int -> BufferState -> IO CharBuffer newCharBuffer (Int lenInt -> Int -> Int forall a. Num a => a -> a -> a *Int 4) BufferState ReadBuffer (Int -> Char -> IO Int) -> Int -> String -> IO Int forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM (\Int i Char c -> RawCharBuffer -> Int -> Char -> IO Int writeCharBuf (CharBuffer -> RawCharBuffer forall e. Buffer e -> RawBuffer e bufRaw CharBuffer cbuf0) Int i Char c) Int 0 String s let cbuf :: CharBuffer cbuf = CharBuffer cbuf0{bufR :: Int bufR=Int len} case TextEncoding enc of TextEncoding {mkTextEncoder :: () mkTextEncoder=IO (TextEncoder estate) mk} -> do TextEncoder estate encoder <- IO (TextEncoder estate) mk [ByteString] bss <- (CharBuffer -> Buffer Word8 -> IO (CodingProgress, CharBuffer, Buffer Word8)) -> CharBuffer -> IO [ByteString] forall e a. (Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8)) -> Buffer e -> IO [ByteString] translate (TextEncoder estate -> CharBuffer -> Buffer Word8 -> IO (CodingProgress, CharBuffer, Buffer Word8) forall from to state. BufferCodec from to state -> CodeBuffer from to encode TextEncoder estate encoder) CharBuffer cbuf TextEncoder estate -> IO () forall from to state. BufferCodec from to state -> IO () close TextEncoder estate encoder ByteString -> IO ByteString forall (m :: * -> *) a. Monad m => a -> m a return ([ByteString] -> ByteString BS.concat [ByteString] bss) where translate :: (Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8)) -> Buffer e -> IO [ByteString] translate Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8) cod Buffer e cbuf | Int i Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int w = do Buffer Word8 bbuf <- Int -> BufferState -> IO (Buffer Word8) newByteBuffer Int 128 BufferState WriteBuffer (a _,Buffer e cbuf,Buffer Word8 bbuf) <- Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8) cod Buffer e cbuf Buffer Word8 bbuf if Buffer Word8 -> Bool forall e. Buffer e -> Bool isEmptyBuffer Buffer Word8 bbuf then IO [ByteString] forall a. IO a ioe_invalidCharacter1 else do let bs :: ByteString bs = ForeignPtr Word8 -> Int -> Int -> ByteString PS (Buffer Word8 -> ForeignPtr Word8 forall e. Buffer e -> RawBuffer e bufRaw Buffer Word8 bbuf) (Buffer Word8 -> Int forall e. Buffer e -> Int bufL Buffer Word8 bbuf) (Buffer Word8 -> Int forall e. Buffer e -> Int bufR Buffer Word8 bbufInt -> Int -> Int forall a. Num a => a -> a -> a -Buffer Word8 -> Int forall e. Buffer e -> Int bufL Buffer Word8 bbuf) [ByteString] bss <- (Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8)) -> Buffer e -> IO [ByteString] translate Buffer e -> Buffer Word8 -> IO (a, Buffer e, Buffer Word8) cod Buffer e cbuf [ByteString] -> IO [ByteString] forall (m :: * -> *) a. Monad m => a -> m a return (ByteString bsByteString -> [ByteString] -> [ByteString] forall a. a -> [a] -> [a] :[ByteString] bss) | Bool otherwise = [ByteString] -> IO [ByteString] forall (m :: * -> *) a. Monad m => a -> m a return [] where i :: Int i = Buffer e -> Int forall e. Buffer e -> Int bufL Buffer e cbuf w :: Int w = Buffer e -> Int forall e. Buffer e -> Int bufR Buffer e cbuf decodeUnicode :: TextEncoding -> ByteString -> String decodeUnicode :: TextEncoding -> ByteString -> String decodeUnicode TextEncoding enc ByteString bs = IO String -> String forall a. IO a -> a unsafePerformIO (IO String -> String) -> IO String -> String forall a b. (a -> b) -> a -> b $ TextEncoding -> ByteString -> IO String decodeUnicodeIO TextEncoding enc ByteString bs decodeUnicodeIO :: TextEncoding -> ByteString -> IO String decodeUnicodeIO TextEncoding enc (PS ForeignPtr Word8 fptr Int l Int len) = do let bbuf :: Buffer Word8 bbuf = Buffer :: forall e. RawBuffer e -> BufferState -> Int -> Int -> Int -> Buffer e Buffer{bufRaw :: ForeignPtr Word8 bufRaw=ForeignPtr Word8 fptr, bufState :: BufferState bufState=BufferState ReadBuffer, bufSize :: Int bufSize=Int len, bufL :: Int bufL=Int l, bufR :: Int bufR=Int lInt -> Int -> Int forall a. Num a => a -> a -> a +Int len} CharBuffer cbuf <- Int -> BufferState -> IO CharBuffer newCharBuffer Int 128 BufferState WriteBuffer case TextEncoding enc of TextEncoding {mkTextDecoder :: () mkTextDecoder=IO (TextDecoder dstate) mk} -> do TextDecoder dstate decoder <- IO (TextDecoder dstate) mk String s <- (Buffer Word8 -> CharBuffer -> IO (CodingProgress, Buffer Word8, CharBuffer)) -> Buffer Word8 -> CharBuffer -> IO String forall e a. (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String translate (TextDecoder dstate -> Buffer Word8 -> CharBuffer -> IO (CodingProgress, Buffer Word8, CharBuffer) forall from to state. BufferCodec from to state -> CodeBuffer from to encode TextDecoder dstate decoder) Buffer Word8 bbuf CharBuffer cbuf TextDecoder dstate -> IO () forall from to state. BufferCodec from to state -> IO () close TextDecoder dstate decoder String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return String s where translate :: (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String translate Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf | Int i Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int w = do (a _,Buffer e bbuf,CharBuffer cbuf) <- Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf if CharBuffer -> Bool forall e. Buffer e -> Bool isEmptyBuffer CharBuffer cbuf then IO String forall a. IO a ioe_invalidCharacter2 else (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String unpack Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf | Bool otherwise = String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return [] where i :: Int i = Buffer e -> Int forall e. Buffer e -> Int bufL Buffer e bbuf w :: Int w = Buffer e -> Int forall e. Buffer e -> Int bufR Buffer e bbuf unpack :: (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String unpack Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf | Int i Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int w = do (Char c,Int i') <- RawCharBuffer -> Int -> IO (Char, Int) readCharBuf (CharBuffer -> RawCharBuffer forall e. Buffer e -> RawBuffer e bufRaw CharBuffer cbuf) Int i String cs <- (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String unpack Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf{bufL :: Int bufL=Int i'} String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return (Char cChar -> String -> String forall a. a -> [a] -> [a] :String cs) | Bool otherwise = (Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer)) -> Buffer e -> CharBuffer -> IO String translate Buffer e -> CharBuffer -> IO (a, Buffer e, CharBuffer) cod Buffer e bbuf CharBuffer cbuf{bufL :: Int bufL=Int 0,bufR :: Int bufR=Int 0} where i :: Int i = CharBuffer -> Int forall e. Buffer e -> Int bufL CharBuffer cbuf w :: Int w = CharBuffer -> Int forall e. Buffer e -> Int bufR CharBuffer cbuf ioe_invalidCharacter1 :: IO a ioe_invalidCharacter1 = IOException -> IO a forall a. IOException -> IO a ioException (Maybe Handle -> IOErrorType -> String -> String -> Maybe CInt -> Maybe String -> IOException IOError Maybe Handle forall a. Maybe a Nothing IOErrorType InvalidArgument String "" (String "invalid byte sequence for this encoding") Maybe CInt forall a. Maybe a Nothing Maybe String forall a. Maybe a Nothing) ioe_invalidCharacter2 :: IO a ioe_invalidCharacter2 = IOException -> IO a forall a. IOException -> IO a ioException (Maybe Handle -> IOErrorType -> String -> String -> Maybe CInt -> Maybe String -> IOException IOError Maybe Handle forall a. Maybe a Nothing IOErrorType InvalidArgument String "" (String "invalid byte sequence for this decoding") Maybe CInt forall a. Maybe a Nothing Maybe String forall a. Maybe a Nothing)