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)