module Codec.Text.IConv.Internal (
IConv,
run,
InitStatus(..),
unsafeInterleave,
unsafeLiftIO,
finalise,
iconv,
Status(..),
pushInputBuffer,
inputBufferSize,
inputBufferEmpty,
inputPosition,
replaceInputBuffer,
newOutputBuffer,
popOutputBuffer,
outputBufferBytesAvailable,
outputBufferFull,
dump,
trace
) where
import Foreign hiding (unsafePerformIO)
import Foreign.C
import qualified Data.ByteString.Internal as S
import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
import System.IO (hPutStrLn, stderr)
import Control.Exception (assert)
import Control.Applicative
import Control.Monad (ap)
import Prelude hiding (length)
pushInputBuffer :: S.ByteString -> IConv ()
pushInputBuffer (S.PS inBuffer' inOffset' inLength') = do
inAvail <- gets inLength
assert (inAvail == 0) $ return ()
modify $ \bufs -> bufs {
inBuffer = inBuffer',
inOffset = inOffset',
inLength = inLength'
}
inputBufferEmpty :: IConv Bool
inputBufferEmpty = gets ((==0) . inLength)
inputBufferSize :: IConv Int
inputBufferSize = gets inLength
inputPosition :: IConv Int
inputPosition = gets inTotal
replaceInputBuffer :: (S.ByteString -> S.ByteString) -> IConv ()
replaceInputBuffer replace =
modify $ \bufs ->
case replace (S.PS (inBuffer bufs) (inOffset bufs) (inLength bufs)) of
S.PS inBuffer' inOffset' inLength' ->
bufs {
inBuffer = inBuffer',
inOffset = inOffset',
inLength = inLength'
}
newOutputBuffer :: Int -> IConv ()
newOutputBuffer size = do
outAvail <- gets outLength
assert (outAvail == 0) $ return ()
outBuffer' <- unsafeLiftIO $ S.mallocByteString size
modify $ \bufs -> bufs {
outBuffer = outBuffer',
outOffset = 0,
outLength = 0,
outFree = size
}
popOutputBuffer :: IConv S.ByteString
popOutputBuffer = do
bufs <- get
assert (outLength bufs > 0) $ return ()
modify $ \buf -> buf {
outOffset = outOffset bufs + outLength bufs,
outLength = 0
}
return (S.PS (outBuffer bufs) (outOffset bufs) (outLength bufs))
outputBufferBytesAvailable :: IConv Int
outputBufferBytesAvailable = gets outLength
outputBufferFull :: IConv Bool
outputBufferFull = gets ((==0) . outFree)
data Buffers = Buffers {
inBuffer :: !(ForeignPtr Word8),
inOffset :: !Int,
inLength :: !Int,
inTotal :: !Int,
outBuffer :: !(ForeignPtr Word8),
outOffset :: !Int,
outLength :: !Int,
outFree :: !Int
} deriving Show
nullBuffers :: Buffers
nullBuffers = Buffers S.nullForeignPtr 0 0 0 S.nullForeignPtr 0 0 0
newtype IConv a = I {
unI :: ConversionDescriptor
-> Buffers
-> IO (Buffers, a)
}
instance Functor IConv where
fmap f a = a >>= returnI . f
instance Applicative IConv where
pure = returnI
(<*>) = ap
instance Monad IConv where
(>>=) = bindI
(>>) = thenI
return = returnI
returnI :: a -> IConv a
returnI a = I $ \_ bufs -> return (bufs, a)
bindI :: IConv a -> (a -> IConv b) -> IConv b
bindI m f = I $ \cd bufs -> do
(bufs', a) <- unI m cd bufs
unI (f a) cd bufs'
thenI :: IConv a -> IConv b -> IConv b
thenI m f = I $ \cd bufs -> do
(bufs', _) <- unI m cd bufs
unI f cd bufs'
data InitStatus = InitOk | UnsupportedConversion | UnexpectedInitError Errno
run :: String -> String -> (InitStatus -> IConv a) -> a
run from to m = unsafePerformIO $ do
ptr <- withCString from $ \fromPtr ->
withCString to $ \toPtr ->
c_iconv_open toPtr fromPtr
(cd, status) <- if ptrToIntPtr ptr /= (1)
then do cd <- newForeignPtr c_iconv_close ptr
return (cd, InitOk)
else do errno <- getErrno
cd <- newForeignPtr_ nullPtr
if errno == eINVAL
then return (cd, UnsupportedConversion)
else return (cd, UnexpectedInitError errno)
(_,a) <- unI (m status) (ConversionDescriptor cd) nullBuffers
return a
unsafeLiftIO :: IO a -> IConv a
unsafeLiftIO m = I $ \_ bufs -> do
a <- m
return (bufs, a)
unsafeInterleave :: IConv a -> IConv a
unsafeInterleave m = I $ \cd st -> do
res <- unsafeInterleaveIO (unI m cd st)
return (st, snd res)
get :: IConv Buffers
get = I $ \_ buf -> return (buf, buf)
gets :: (Buffers -> a) -> IConv a
gets getter = I $ \_ buf -> return (buf, getter buf)
modify :: (Buffers -> Buffers) -> IConv ()
modify change = I $ \_ buf -> return (change buf, ())
trace :: String -> IConv ()
trace = unsafeLiftIO . hPutStrLn stderr
dump :: IConv ()
dump = do
bufs <- get
unsafeLiftIO $ hPutStrLn stderr $ show bufs
data Status =
InputEmpty
| OutputFull
| IncompleteChar
| InvalidChar
| UnexpectedError Errno
iconv :: IConv Status
iconv = I $ \(ConversionDescriptor cdfptr) bufs ->
assert (outFree bufs > 0) $
withForeignPtr cdfptr $ \cdPtr ->
withForeignPtr (inBuffer bufs) $ \inBufPtr ->
with (inBufPtr `plusPtr` inOffset bufs) $ \inBufPtrPtr ->
with (fromIntegral (inLength bufs)) $ \inLengthPtr ->
withForeignPtr (outBuffer bufs) $ \outBufPtr ->
let outBufPtr' = outBufPtr `plusPtr` (outOffset bufs + outLength bufs) in
with outBufPtr' $ \outBufPtrPtr ->
with (fromIntegral (outFree bufs)) $ \outFreePtr -> do
result <- c_iconv cdPtr inBufPtrPtr inLengthPtr outBufPtrPtr outFreePtr
inLength' <- fromIntegral `fmap` peek inLengthPtr
outFree' <- fromIntegral `fmap` peek outFreePtr
let inByteCount = inLength bufs inLength'
outByteCount = outFree bufs outFree'
bufs' = bufs {
inOffset = inOffset bufs + inByteCount,
inLength = inLength',
inTotal = inTotal bufs + inByteCount,
outLength = outLength bufs + outByteCount,
outFree = outFree'
}
if result /= errVal
then return (bufs', InputEmpty)
else do errno <- getErrno
case () of
_ | errno == e2BIG -> return (bufs', OutputFull)
| errno == eINVAL -> return (bufs', IncompleteChar)
| errno == eILSEQ -> return (bufs', InvalidChar)
| otherwise -> return (bufs', UnexpectedError errno)
where errVal :: CSize
errVal = (1)
finalise :: IConv ()
finalise = I $ \(ConversionDescriptor cd) bufs -> do
finalizeForeignPtr cd
return (bufs, ())
newtype ConversionDescriptor = ConversionDescriptor (ForeignPtr ConversionDescriptor)
foreign import ccall unsafe "hsiconv.h hs_wrap_iconv_open"
c_iconv_open :: CString
-> CString
-> IO (Ptr ConversionDescriptor)
foreign import ccall unsafe "hsiconv.h hs_wrap_iconv"
c_iconv :: Ptr ConversionDescriptor
-> Ptr (Ptr CChar)
-> Ptr CSize
-> Ptr (Ptr CChar)
-> Ptr CSize
-> IO CSize
foreign import ccall unsafe "hsiconv.h &hs_wrap_iconv_close"
c_iconv_close :: FinalizerPtr ConversionDescriptor