(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP , NoImplicitPrelude , NondecreasingIndentation #-} {-# OPTIONS_HADDOCK not-home #-}

module GHC.IO.Encoding.Iconv ( #if !defined(mingw32_HOST_OS) iconvEncoding, mkIconvEncoding, localeEncodingName #endif ) where

#include "MachDeps.h" #include "HsBaseConfig.h"

#if defined(mingw32_HOST_OS) import GHC.Base () #else

import Foreign import Foreign.C hiding (charIsRepresentable) import Data.Maybe import GHC.Base import GHC.Foreign (charIsRepresentable) import GHC.IO.Buffer import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.List (span) import GHC.Num import GHC.Show import GHC.Real import System.IO.Unsafe (unsafePerformIO) import System.Posix.Internals

c_DEBUG_DUMP :: Bool c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = Bool False

iconv_trace :: String -> IO () iconv_trace :: String -> IO () iconv_trace String s | Bool c_DEBUG_DUMP = String -> IO () puts String s | Bool otherwise = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return ()

{-# NOINLINE localeEncodingName #-} localeEncodingName :: String localeEncodingName :: String localeEncodingName = IO String -> String forall a. IO a -> a unsafePerformIO (IO String -> String) -> IO String -> String forall a b. (a -> b) -> a -> b $ do

CString cstr <- IO CString c_localeEncoding CString -> IO String peekCAString CString cstr

type IConv = CLong

foreign import ccall unsafe "hs_iconv_open" hs_iconv_open :: CString -> CString -> IO IConv

foreign import ccall unsafe "hs_iconv_close" hs_iconv_close :: IConv -> IO CInt

foreign import ccall unsafe "hs_iconv" hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CSize

foreign import ccall unsafe "localeEncoding" c_localeEncoding :: IO CString

haskellChar :: String #if defined(WORDS_BIGENDIAN) haskellChar | charSize == 2 = "UTF-16BE" | otherwise = "UTF-32BE" #else haskellChar :: String haskellChar | Int charSize Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 2 = String "UTF-16LE" | Bool otherwise = String "UTF-32LE" #endif

char_shift :: Int char_shift :: Int char_shift | Int charSize Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 2 = Int 1 | Bool otherwise = Int 2

iconvEncoding :: String -> IO (Maybe TextEncoding) iconvEncoding :: String -> IO (Maybe TextEncoding) iconvEncoding = CodingFailureMode -> String -> IO (Maybe TextEncoding) mkIconvEncoding CodingFailureMode ErrorOnCodingFailure

mkIconvEncoding :: CodingFailureMode -> String -> IO (Maybe TextEncoding) mkIconvEncoding :: CodingFailureMode -> String -> IO (Maybe TextEncoding) mkIconvEncoding CodingFailureMode cfm String charset = do let enc :: TextEncoding enc = TextEncoding { textEncodingName :: String textEncodingName = String charset, mkTextDecoder :: IO (TextDecoder ()) mkTextDecoder = String -> String -> (Buffer Word8 -> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem)) -> (IConv -> Buffer Word8 -> Buffer CharBufElem -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem)) -> IO (TextDecoder ()) forall a b. String -> String -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (BufferCodec a b ()) newIConv String raw_charset (String haskellChar String -> String -> String forall a. [a] -> [a] -> [a] ++ String suffix) (CodingFailureMode -> Buffer Word8 -> Buffer CharBufElem -> IO (Buffer Word8, Buffer CharBufElem) recoverDecode CodingFailureMode cfm) IConv -> Buffer Word8 -> Buffer CharBufElem -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem) iconvDecode, mkTextEncoder :: IO (TextEncoder ()) mkTextEncoder = String -> String -> (Buffer CharBufElem -> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8)) -> (IConv -> Buffer CharBufElem -> Buffer Word8 -> IO (CodingProgress, Buffer CharBufElem, Buffer Word8)) -> IO (TextEncoder ()) forall a b. String -> String -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (BufferCodec a b ()) newIConv String haskellChar String charset (CodingFailureMode -> Buffer CharBufElem -> Buffer Word8 -> IO (Buffer CharBufElem, Buffer Word8) recoverEncode CodingFailureMode cfm) IConv -> Buffer CharBufElem -> Buffer Word8 -> IO (CodingProgress, Buffer CharBufElem, Buffer Word8) iconvEncode} Bool good <- TextEncoding -> CharBufElem -> IO Bool charIsRepresentable TextEncoding enc CharBufElem 'a' Maybe TextEncoding -> IO (Maybe TextEncoding) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Maybe TextEncoding -> IO (Maybe TextEncoding)) -> Maybe TextEncoding -> IO (Maybe TextEncoding) forall a b. (a -> b) -> a -> b $ if Bool good then TextEncoding -> Maybe TextEncoding forall a. a -> Maybe a Just TextEncoding enc else Maybe TextEncoding forall a. Maybe a Nothing where

(String

raw_charset, String suffix) = (CharBufElem -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) span (CharBufElem -> CharBufElem -> Bool forall a. Eq a => a -> a -> Bool /= CharBufElem '/') String charset

newIConv :: String -> String -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (BufferCodec a b ()) newIConv :: forall a b. String -> String -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (BufferCodec a b ()) newIConv String from String to Buffer a -> Buffer b -> IO (Buffer a, Buffer b) rec IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b) fn =

String -> (CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ()) forall a. String -> (CString -> IO a) -> IO a withCAString String from ((CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ())) -> (CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ()) forall a b. (a -> b) -> a -> b $ \ CString from_str -> String -> (CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ()) forall a. String -> (CString -> IO a) -> IO a withCAString String to ((CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ())) -> (CString -> IO (BufferCodec a b ())) -> IO (BufferCodec a b ()) forall a b. (a -> b) -> a -> b $ \ CString to_str -> do IConv iconvt <- String -> IO IConv -> IO IConv forall a. (Eq a, Num a) => String -> IO a -> IO a throwErrnoIfMinus1 String "mkTextEncoding" (IO IConv -> IO IConv) -> IO IConv -> IO IConv forall a b. (a -> b) -> a -> b $ CString -> CString -> IO IConv hs_iconv_open CString to_str CString from_str let iclose :: IO () iclose = String -> IO CInt -> IO () forall a. (Eq a, Num a) => String -> IO a -> IO () throwErrnoIfMinus1_ String "Iconv.close" (IO CInt -> IO ()) -> IO CInt -> IO () forall a b. (a -> b) -> a -> b $ IConv -> IO CInt hs_iconv_close IConv iconvt BufferCodec a b () -> IO (BufferCodec a b ()) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return BufferCodec{ encode :: Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b) encode = IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b) fn IConv iconvt, recover :: Buffer a -> Buffer b -> IO (Buffer a, Buffer b) recover = Buffer a -> Buffer b -> IO (Buffer a, Buffer b) rec, close :: IO () close = IO () iclose,

            getState :: IO ()

getState = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (), setState :: () -> IO () setState = IO () -> () -> IO () forall a b. a -> b -> a const (IO () -> () -> IO ()) -> IO () -> () -> IO () forall a b. (a -> b) -> a -> b $ () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () }

iconvDecode :: IConv -> DecodeBuffer iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem) iconvDecode IConv iconv_t Buffer Word8 ibuf Buffer CharBufElem obuf = IConv -> Buffer Word8 -> Int -> Buffer CharBufElem -> Int -> IO (CodingProgress, Buffer Word8, Buffer CharBufElem) forall a b. IConv -> Buffer a -> Int -> Buffer b -> Int -> IO (CodingProgress, Buffer a, Buffer b) iconvRecode IConv iconv_t Buffer Word8 ibuf Int 0 Buffer CharBufElem obuf Int char_shift

iconvEncode :: IConv -> EncodeBuffer iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8 -> IO (CodingProgress, Buffer CharBufElem, Buffer Word8) iconvEncode IConv iconv_t Buffer CharBufElem ibuf Buffer Word8 obuf = IConv -> Buffer CharBufElem -> Int -> Buffer Word8 -> Int -> IO (CodingProgress, Buffer CharBufElem, Buffer Word8) forall a b. IConv -> Buffer a -> Int -> Buffer b -> Int -> IO (CodingProgress, Buffer a, Buffer b) iconvRecode IConv iconv_t Buffer CharBufElem ibuf Int char_shift Buffer Word8 obuf Int 0

iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int -> IO (CodingProgress, Buffer a, Buffer b) iconvRecode :: forall a b. IConv -> Buffer a -> Int -> Buffer b -> Int -> IO (CodingProgress, Buffer a, Buffer b) iconvRecode IConv iconv_t input :: Buffer a input@Buffer{ bufRaw :: forall e. Buffer e -> RawBuffer e bufRaw=RawBuffer a iraw, bufL :: forall e. Buffer e -> Int bufL=Int ir, bufR :: forall e. Buffer e -> Int bufR=Int iw, bufSize :: forall e. Buffer e -> Int bufSize=Int _ } Int iscale output :: Buffer b output@Buffer{ bufRaw :: forall e. Buffer e -> RawBuffer e bufRaw=RawBuffer b oraw, bufL :: forall e. Buffer e -> Int bufL=Int _, bufR :: forall e. Buffer e -> Int bufR=Int ow, bufSize :: forall e. Buffer e -> Int bufSize=Int os } Int oscale = do String -> IO () iconv_trace (String "haskellChar=" String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String haskellChar) String -> IO () iconv_trace (String "iconvRecode before, input=" String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show (Buffer a -> String forall a. Buffer a -> String summaryBuffer Buffer a input)) String -> IO () iconv_trace (String "iconvRecode before, output=" String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show (Buffer b -> String forall a. Buffer a -> String summaryBuffer Buffer b output)) RawBuffer a -> (Ptr a -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a withRawBuffer RawBuffer a iraw ((Ptr a -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr a -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr a piraw -> do RawBuffer b -> (Ptr b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall e a. RawBuffer e -> (Ptr e -> IO a) -> IO a withRawBuffer RawBuffer b oraw ((Ptr b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr b poraw -> do CString -> (Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b with (Ptr a piraw Ptr a -> Int -> CString forall a b. Ptr a -> Int -> Ptr b plusPtr (Int ir Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftL Int iscale)) ((Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr CString p_inbuf -> do CString -> (Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b with (Ptr b poraw Ptr b -> Int -> CString forall a b. Ptr a -> Int -> Ptr b plusPtr (Int ow Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftL Int oscale)) ((Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr CString -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr CString p_outbuf -> do CSize -> (Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b with (Int -> CSize forall a b. (Integral a, Num b) => a -> b fromIntegral ((Int iwInt -> Int -> Int forall a. Num a => a -> a -> a -Int ir) Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftL Int iscale)) ((Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr CSize p_inleft -> do CSize -> (Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b with (Int -> CSize forall a b. (Integral a, Num b) => a -> b fromIntegral ((Int osInt -> Int -> Int forall a. Num a => a -> a -> a -Int ow) Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftL Int oscale)) ((Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b)) -> (Ptr CSize -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (CodingProgress, Buffer a, Buffer b) forall a b. (a -> b) -> a -> b $ \ Ptr CSize p_outleft -> do CSize res <- IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CSize hs_iconv IConv iconv_t Ptr CString p_inbuf Ptr CSize p_inleft Ptr CString p_outbuf Ptr CSize p_outleft CSize new_inleft <- Ptr CSize -> IO CSize forall a. Storable a => Ptr a -> IO a peek Ptr CSize p_inleft CSize new_outleft <- Ptr CSize -> IO CSize forall a. Storable a => Ptr a -> IO a peek Ptr CSize p_outleft let new_inleft' :: Int new_inleft' = CSize -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral CSize new_inleft Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftR Int iscale new_outleft' :: Int new_outleft' = CSize -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral CSize new_outleft Int -> Int -> Int forall a. Bits a => a -> Int -> a shiftR Int oscale new_input :: Buffer a new_input | CSize new_inleft CSize -> CSize -> Bool forall a. Eq a => a -> a -> Bool == CSize 0 = Buffer a input { bufL :: Int bufL = Int 0, bufR :: Int bufR = Int 0 } | Bool otherwise = Buffer a input { bufL :: Int bufL = Int iw Int -> Int -> Int forall a. Num a => a -> a -> a - Int new_inleft' } new_output :: Buffer b new_output = Buffer b output{ bufR :: Int bufR = Int os Int -> Int -> Int forall a. Num a => a -> a -> a - Int new_outleft' } String -> IO () iconv_trace (String "iconv res=" String -> String -> String forall a. [a] -> [a] -> [a] ++ CSize -> String forall a. Show a => a -> String show CSize res) String -> IO () iconv_trace (String "iconvRecode after, input=" String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show (Buffer a -> String forall a. Buffer a -> String summaryBuffer Buffer a new_input)) String -> IO () iconv_trace (String "iconvRecode after, output=" String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show (Buffer b -> String forall a. Buffer a -> String summaryBuffer Buffer b new_output)) if (CSize res CSize -> CSize -> Bool forall a. Eq a => a -> a -> Bool /= -CSize 1) then (CodingProgress, Buffer a, Buffer b) -> IO (CodingProgress, Buffer a, Buffer b) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (CodingProgress InputUnderflow, Buffer a new_input, Buffer b new_output) else do Errno errno <- IO Errno getErrno case Errno errno of Errno e | Errno e Errno -> Errno -> Bool forall a. Eq a => a -> a -> Bool == Errno e2BIG -> (CodingProgress, Buffer a, Buffer b) -> IO (CodingProgress, Buffer a, Buffer b) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (CodingProgress OutputUnderflow, Buffer a new_input, Buffer b new_output) | Errno e Errno -> Errno -> Bool forall a. Eq a => a -> a -> Bool == Errno eINVAL -> (CodingProgress, Buffer a, Buffer b) -> IO (CodingProgress, Buffer a, Buffer b) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (CodingProgress InputUnderflow, Buffer a new_input, Buffer b new_output)

      | Errno

e Errno -> Errno -> Bool forall a. Eq a => a -> a -> Bool == Errno eILSEQ -> (CodingProgress, Buffer a, Buffer b) -> IO (CodingProgress, Buffer a, Buffer b) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (if Int new_outleft' Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0 then CodingProgress OutputUnderflow else CodingProgress InvalidSequence, Buffer a new_input, Buffer b new_output) | Bool otherwise -> do String -> IO () iconv_trace (String "iconv returned error: " String -> String -> String forall a. [a] -> [a] -> [a] ++ IOError -> String forall a. Show a => a -> String show (String -> Errno -> Maybe Handle -> Maybe String -> IOError errnoToIOError String "iconv" Errno e Maybe Handle forall a. Maybe a Nothing Maybe String forall a. Maybe a Nothing)) String -> IO (CodingProgress, Buffer a, Buffer b) forall a. String -> IO a throwErrno String "iconvRecoder"

#endif /* !mingw32_HOST_OS */