-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) 2006-2007 Duncan Coutts
-- License     :  BSD-style
--
-- Maintainer  :  duncan@haskell.org
-- Portability :  portable (H98 + FFI)
--
-- IConv wrapper layer
--
-----------------------------------------------------------------------------
module Codec.Text.IConv.Internal (

  -- * The iconv state monad
  IConv,
  run,
  InitStatus(..),
  unsafeInterleave,
  unsafeLiftIO,
  finalise,

  -- * The buisness
  iconv,
  Status(..),

  -- * Buffer management
  -- ** Input buffer
  pushInputBuffer,
  inputBufferSize,
  inputBufferEmpty,
  inputPosition,
  replaceInputBuffer,

  -- ** Output buffer
  newOutputBuffer,
  popOutputBuffer,
  outputBufferBytesAvailable,
  outputBufferFull,

  -- * Debugging
--  consistencyCheck,
  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 :: ByteString -> IConv ()
pushInputBuffer (S.PS inBuffer' :: ForeignPtr Word8
inBuffer' inOffset' :: Int
inOffset' inLength' :: Int
inLength') = do

  -- must not push a new input buffer if the last one is not used up
  Int
inAvail <- (Buffers -> Int) -> IConv Int
forall a. (Buffers -> a) -> IConv a
gets Buffers -> Int
inLength
  Bool -> IConv () -> IConv ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
inAvail Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IConv () -> IConv ()) -> IConv () -> IConv ()
forall a b. (a -> b) -> a -> b
$ () -> IConv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- now set the available input buffer ptr and length
  (Buffers -> Buffers) -> IConv ()
modify ((Buffers -> Buffers) -> IConv ())
-> (Buffers -> Buffers) -> IConv ()
forall a b. (a -> b) -> a -> b
$ \bufs :: Buffers
bufs -> Buffers
bufs {
    inBuffer :: ForeignPtr Word8
inBuffer = ForeignPtr Word8
inBuffer',
    inOffset :: Int
inOffset = Int
inOffset',
    inLength :: Int
inLength = Int
inLength'
  }


inputBufferEmpty :: IConv Bool
inputBufferEmpty :: IConv Bool
inputBufferEmpty = (Buffers -> Bool) -> IConv Bool
forall a. (Buffers -> a) -> IConv a
gets ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0) (Int -> Bool) -> (Buffers -> Int) -> Buffers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffers -> Int
inLength)


inputBufferSize :: IConv Int
inputBufferSize :: IConv Int
inputBufferSize = (Buffers -> Int) -> IConv Int
forall a. (Buffers -> a) -> IConv a
gets Buffers -> Int
inLength


inputPosition :: IConv Int
inputPosition :: IConv Int
inputPosition = (Buffers -> Int) -> IConv Int
forall a. (Buffers -> a) -> IConv a
gets Buffers -> Int
inTotal


replaceInputBuffer :: (S.ByteString -> S.ByteString) -> IConv ()
replaceInputBuffer :: (ByteString -> ByteString) -> IConv ()
replaceInputBuffer replace :: ByteString -> ByteString
replace =
  (Buffers -> Buffers) -> IConv ()
modify ((Buffers -> Buffers) -> IConv ())
-> (Buffers -> Buffers) -> IConv ()
forall a b. (a -> b) -> a -> b
$ \bufs :: Buffers
bufs ->
    case ByteString -> ByteString
replace (ForeignPtr Word8 -> Int -> Int -> ByteString
S.PS (Buffers -> ForeignPtr Word8
inBuffer Buffers
bufs) (Buffers -> Int
inOffset Buffers
bufs) (Buffers -> Int
inLength Buffers
bufs)) of
      S.PS inBuffer' :: ForeignPtr Word8
inBuffer' inOffset' :: Int
inOffset' inLength' :: Int
inLength' ->
        Buffers
bufs {
          inBuffer :: ForeignPtr Word8
inBuffer = ForeignPtr Word8
inBuffer',
          inOffset :: Int
inOffset = Int
inOffset',
          inLength :: Int
inLength = Int
inLength'
        }


newOutputBuffer :: Int -> IConv ()
newOutputBuffer :: Int -> IConv ()
newOutputBuffer size :: Int
size = do

  --must not push a new buffer if there is still data in the old one
  Int
outAvail <- (Buffers -> Int) -> IConv Int
forall a. (Buffers -> a) -> IConv a
gets Buffers -> Int
outLength
  Bool -> IConv () -> IConv ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
outAvail Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IConv () -> IConv ()) -> IConv () -> IConv ()
forall a b. (a -> b) -> a -> b
$ () -> IConv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- Note that there may still be free space in the output buffer, that's ok,
  -- you might not want to bother completely filling the output buffer say if
  -- there's only a few free bytes left.

  -- now set the available output buffer ptr and length
  ForeignPtr Word8
outBuffer' <- IO (ForeignPtr Word8) -> IConv (ForeignPtr Word8)
forall a. IO a -> IConv a
unsafeLiftIO (IO (ForeignPtr Word8) -> IConv (ForeignPtr Word8))
-> IO (ForeignPtr Word8) -> IConv (ForeignPtr Word8)
forall a b. (a -> b) -> a -> b
$ Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
S.mallocByteString Int
size
  (Buffers -> Buffers) -> IConv ()
modify ((Buffers -> Buffers) -> IConv ())
-> (Buffers -> Buffers) -> IConv ()
forall a b. (a -> b) -> a -> b
$ \bufs :: Buffers
bufs -> Buffers
bufs {
      outBuffer :: ForeignPtr Word8
outBuffer = ForeignPtr Word8
outBuffer',
      outOffset :: Int
outOffset = 0,
      outLength :: Int
outLength = 0,
      outFree :: Int
outFree   = Int
size
    }


-- get that part of the output buffer that is currently full
-- (might be 0, use outputBufferBytesAvailable to check)
-- this may leave some space remaining in the buffer
popOutputBuffer :: IConv S.ByteString
popOutputBuffer :: IConv ByteString
popOutputBuffer = do

  Buffers
bufs <- IConv Buffers
get

  -- there really should be something to pop, otherwise it's silly
  Bool -> IConv () -> IConv ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Buffers -> Int
outLength Buffers
bufs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IConv () -> IConv ()) -> IConv () -> IConv ()
forall a b. (a -> b) -> a -> b
$ () -> IConv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  (Buffers -> Buffers) -> IConv ()
modify ((Buffers -> Buffers) -> IConv ())
-> (Buffers -> Buffers) -> IConv ()
forall a b. (a -> b) -> a -> b
$ \buf :: Buffers
buf -> Buffers
buf {
      outOffset :: Int
outOffset = Buffers -> Int
outOffset Buffers
bufs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Buffers -> Int
outLength Buffers
bufs,
      outLength :: Int
outLength = 0
    }

  ByteString -> IConv ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> ByteString
S.PS (Buffers -> ForeignPtr Word8
outBuffer Buffers
bufs) (Buffers -> Int
outOffset Buffers
bufs) (Buffers -> Int
outLength Buffers
bufs))


-- this is the number of bytes available in the output buffer
outputBufferBytesAvailable :: IConv Int
outputBufferBytesAvailable :: IConv Int
outputBufferBytesAvailable = (Buffers -> Int) -> IConv Int
forall a. (Buffers -> a) -> IConv a
gets Buffers -> Int
outLength


-- you only need to supply a new buffer when there is no more output buffer
-- space remaining
outputBufferFull :: IConv Bool
outputBufferFull :: IConv Bool
outputBufferFull = (Buffers -> Bool) -> IConv Bool
forall a. (Buffers -> a) -> IConv a
gets ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0) (Int -> Bool) -> (Buffers -> Int) -> Buffers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffers -> Int
outFree)


----------------------------
-- IConv buffer layout
--

data Buffers = Buffers {
    Buffers -> ForeignPtr Word8
inBuffer  :: {-# UNPACK #-} !(ForeignPtr Word8), -- ^ Current input buffer
    Buffers -> Int
inOffset  :: {-# UNPACK #-} !Int,                -- ^ Current read offset
    Buffers -> Int
inLength  :: {-# UNPACK #-} !Int,                -- ^ Input bytes left
    Buffers -> Int
inTotal   :: {-# UNPACK #-} !Int,                -- ^ Total read offset
    Buffers -> ForeignPtr Word8
outBuffer :: {-# UNPACK #-} !(ForeignPtr Word8), -- ^ Current output buffer
    Buffers -> Int
outOffset :: {-# UNPACK #-} !Int,                -- ^ Base out offset
    Buffers -> Int
outLength :: {-# UNPACK #-} !Int,                -- ^ Available output bytes
    Buffers -> Int
outFree   :: {-# UNPACK #-} !Int                 -- ^ Free output space
  } deriving Int -> Buffers -> ShowS
[Buffers] -> ShowS
Buffers -> String
(Int -> Buffers -> ShowS)
-> (Buffers -> String) -> ([Buffers] -> ShowS) -> Show Buffers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Buffers] -> ShowS
$cshowList :: [Buffers] -> ShowS
show :: Buffers -> String
$cshow :: Buffers -> String
showsPrec :: Int -> Buffers -> ShowS
$cshowsPrec :: Int -> Buffers -> ShowS
Show

nullBuffers :: Buffers
nullBuffers :: Buffers
nullBuffers = ForeignPtr Word8
-> Int
-> Int
-> Int
-> ForeignPtr Word8
-> Int
-> Int
-> Int
-> Buffers
Buffers ForeignPtr Word8
S.nullForeignPtr 0 0 0 ForeignPtr Word8
S.nullForeignPtr 0 0 0

{-
 - For the output buffer we have this setup:
 -
 - +-------------+-------------+----------+
 - |### poped ###|** current **|   free   |
 - +-------------+-------------+----------+
 -  \           / \           / \         /
 -    outOffset     outLength     outFree
 -
 - The output buffer is allocated by us and pointer to by the outBuf ForeignPtr.
 - An initial prefix of the buffer that we have already poped/yielded. This bit
 - is immutable, it's already been handed out to the caller, we cannot touch it.
 - When we yield we increment the outOffset. The next part of the buffer between
 - outBuf + outOffset and outBuf + outOffset + outLength is the current bit that
 - has had output data written into it but we have not yet yielded it to the
 - caller. Finally, we have the free part of the buffer. This is the bit we
 - provide to iconv to be filled. When it is written to, we increase the
 - outLength and decrease the outLeft by the number of bytes written.

 - The input buffer layout is much simpler, it's basically just a bytestring:
 -
 - +------------+------------+
 - |### done ###|  remaining |
 - +------------+------------+
 -  \          / \          /
 -    inOffset     inLength
 -
 - So when we iconv we increase the inOffset and decrease the inLength by the
 - number of bytes read.
 -}


----------------------------
-- IConv monad
--

newtype IConv a = I {
    IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI :: ConversionDescriptor
        -> Buffers
        -> IO (Buffers, a)
  }

instance Functor IConv where
  fmap :: (a -> b) -> IConv a -> IConv b
fmap f :: a -> b
f a :: IConv a
a = IConv a
a IConv a -> (a -> IConv b) -> IConv b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> IConv b
forall a. a -> IConv a
returnI (b -> IConv b) -> (a -> b) -> a -> IConv b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance Applicative IConv where
  pure :: a -> IConv a
pure  = a -> IConv a
forall a. a -> IConv a
returnI
  <*> :: IConv (a -> b) -> IConv a -> IConv b
(<*>) = IConv (a -> b) -> IConv a -> IConv b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad IConv where
  >>= :: IConv a -> (a -> IConv b) -> IConv b
(>>=)  = IConv a -> (a -> IConv b) -> IConv b
forall a b. IConv a -> (a -> IConv b) -> IConv b
bindI
--  m >>= f = (m `bindI` \a -> consistencyCheck `thenI` returnI a) `bindI` f
  >> :: IConv a -> IConv b -> IConv b
(>>)   = IConv a -> IConv b -> IConv b
forall a b. IConv a -> IConv b -> IConv b
thenI
  return :: a -> IConv a
return = a -> IConv a
forall a. a -> IConv a
returnI

returnI :: a -> IConv a
returnI :: a -> IConv a
returnI a :: a
a = (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a b. (a -> b) -> a -> b
$ \_ bufs :: Buffers
bufs -> (Buffers, a) -> IO (Buffers, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs, a
a)
{-# INLINE returnI #-}

bindI :: IConv a -> (a -> IConv b) -> IConv b
bindI :: IConv a -> (a -> IConv b) -> IConv b
bindI m :: IConv a
m f :: a -> IConv b
f = (ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b
forall a b. (a -> b) -> a -> b
$ \cd :: ConversionDescriptor
cd bufs :: Buffers
bufs -> do
  (bufs' :: Buffers
bufs', a :: a
a) <- IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI IConv a
m ConversionDescriptor
cd Buffers
bufs
  IConv b -> ConversionDescriptor -> Buffers -> IO (Buffers, b)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI (a -> IConv b
f a
a) ConversionDescriptor
cd Buffers
bufs'
{-# INLINE bindI #-}

thenI :: IConv a -> IConv b -> IConv b
thenI :: IConv a -> IConv b -> IConv b
thenI m :: IConv a
m f :: IConv b
f = (ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, b)) -> IConv b
forall a b. (a -> b) -> a -> b
$ \cd :: ConversionDescriptor
cd bufs :: Buffers
bufs -> do
  (bufs' :: Buffers
bufs', _) <- IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI IConv a
m ConversionDescriptor
cd Buffers
bufs
  IConv b -> ConversionDescriptor -> Buffers -> IO (Buffers, b)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI IConv b
f ConversionDescriptor
cd Buffers
bufs'
{-# INLINE thenI #-}

data InitStatus = InitOk | UnsupportedConversion | UnexpectedInitError Errno

{-# NOINLINE run #-}
run :: String -> String -> (InitStatus -> IConv a) -> a
run :: String -> String -> (InitStatus -> IConv a) -> a
run from :: String
from to :: String
to m :: InitStatus -> IConv a
m = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
  Ptr ConversionDescriptor
ptr <- String
-> (CString -> IO (Ptr ConversionDescriptor))
-> IO (Ptr ConversionDescriptor)
forall a. String -> (CString -> IO a) -> IO a
withCString String
from ((CString -> IO (Ptr ConversionDescriptor))
 -> IO (Ptr ConversionDescriptor))
-> (CString -> IO (Ptr ConversionDescriptor))
-> IO (Ptr ConversionDescriptor)
forall a b. (a -> b) -> a -> b
$ \fromPtr :: CString
fromPtr ->
         String
-> (CString -> IO (Ptr ConversionDescriptor))
-> IO (Ptr ConversionDescriptor)
forall a. String -> (CString -> IO a) -> IO a
withCString String
to ((CString -> IO (Ptr ConversionDescriptor))
 -> IO (Ptr ConversionDescriptor))
-> (CString -> IO (Ptr ConversionDescriptor))
-> IO (Ptr ConversionDescriptor)
forall a b. (a -> b) -> a -> b
$ \toPtr :: CString
toPtr ->
           CString -> CString -> IO (Ptr ConversionDescriptor)
c_iconv_open CString
toPtr CString
fromPtr -- note arg reversal

  (cd :: ForeignPtr ConversionDescriptor
cd, status :: InitStatus
status) <- if Ptr ConversionDescriptor -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr Ptr ConversionDescriptor
ptr IntPtr -> IntPtr -> Bool
forall a. Eq a => a -> a -> Bool
/= (-1)
                    then do ForeignPtr ConversionDescriptor
cd <- FinalizerPtr ConversionDescriptor
-> Ptr ConversionDescriptor -> IO (ForeignPtr ConversionDescriptor)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ConversionDescriptor
c_iconv_close Ptr ConversionDescriptor
ptr
                            (ForeignPtr ConversionDescriptor, InitStatus)
-> IO (ForeignPtr ConversionDescriptor, InitStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr ConversionDescriptor
cd, InitStatus
InitOk)
                    else do Errno
errno <- IO Errno
getErrno
                            ForeignPtr ConversionDescriptor
cd <- Ptr ConversionDescriptor -> IO (ForeignPtr ConversionDescriptor)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr ConversionDescriptor
forall a. Ptr a
nullPtr
                            if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINVAL
                              then (ForeignPtr ConversionDescriptor, InitStatus)
-> IO (ForeignPtr ConversionDescriptor, InitStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr ConversionDescriptor
cd, InitStatus
UnsupportedConversion)
                              else (ForeignPtr ConversionDescriptor, InitStatus)
-> IO (ForeignPtr ConversionDescriptor, InitStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr ConversionDescriptor
cd, Errno -> InitStatus
UnexpectedInitError Errno
errno)
  (_,a :: a
a) <- IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI (InitStatus -> IConv a
m InitStatus
status) (ForeignPtr ConversionDescriptor -> ConversionDescriptor
ConversionDescriptor ForeignPtr ConversionDescriptor
cd) Buffers
nullBuffers
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

unsafeLiftIO :: IO a -> IConv a
unsafeLiftIO :: IO a -> IConv a
unsafeLiftIO m :: IO a
m = (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a b. (a -> b) -> a -> b
$ \_ bufs :: Buffers
bufs -> do
  a
a <- IO a
m
  (Buffers, a) -> IO (Buffers, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs, a
a)

-- It's unsafe because we discard the values here, so if you mutate anything
-- between running this and forcing the result then you'll get an inconsistent
-- iconv state.
unsafeInterleave :: IConv a -> IConv a
unsafeInterleave :: IConv a -> IConv a
unsafeInterleave m :: IConv a
m = (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a b. (a -> b) -> a -> b
$ \cd :: ConversionDescriptor
cd st :: Buffers
st -> do
  (Buffers, a)
res <- IO (Buffers, a) -> IO (Buffers, a)
forall a. IO a -> IO a
unsafeInterleaveIO (IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
forall a.
IConv a -> ConversionDescriptor -> Buffers -> IO (Buffers, a)
unI IConv a
m ConversionDescriptor
cd Buffers
st)
  (Buffers, a) -> IO (Buffers, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
st, (Buffers, a) -> a
forall a b. (a, b) -> b
snd (Buffers, a)
res)

get :: IConv Buffers
get :: IConv Buffers
get = (ConversionDescriptor -> Buffers -> IO (Buffers, Buffers))
-> IConv Buffers
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, Buffers))
 -> IConv Buffers)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, Buffers))
-> IConv Buffers
forall a b. (a -> b) -> a -> b
$ \_ buf :: Buffers
buf -> (Buffers, Buffers) -> IO (Buffers, Buffers)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
buf, Buffers
buf)

gets :: (Buffers -> a) -> IConv a
gets :: (Buffers -> a) -> IConv a
gets getter :: Buffers -> a
getter = (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
forall a b. (a -> b) -> a -> b
$ \_ buf :: Buffers
buf -> (Buffers, a) -> IO (Buffers, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
buf, Buffers -> a
getter Buffers
buf)

modify :: (Buffers -> Buffers) -> IConv ()
modify :: (Buffers -> Buffers) -> IConv ()
modify change :: Buffers -> Buffers
change = (ConversionDescriptor -> Buffers -> IO (Buffers, ())) -> IConv ()
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, ())) -> IConv ())
-> (ConversionDescriptor -> Buffers -> IO (Buffers, ()))
-> IConv ()
forall a b. (a -> b) -> a -> b
$ \_ buf :: Buffers
buf -> (Buffers, ()) -> IO (Buffers, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers -> Buffers
change Buffers
buf, ())

----------------------------
-- Debug stuff
--

trace :: String -> IConv ()
trace :: String -> IConv ()
trace = IO () -> IConv ()
forall a. IO a -> IConv a
unsafeLiftIO (IO () -> IConv ()) -> (String -> IO ()) -> String -> IConv ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr


dump :: IConv ()
dump :: IConv ()
dump = do
  Buffers
bufs <- IConv Buffers
get
  IO () -> IConv ()
forall a. IO a -> IConv a
unsafeLiftIO (IO () -> IConv ()) -> IO () -> IConv ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffers -> String
forall a. Show a => a -> String
show Buffers
bufs

----------------------------
-- iconv wrapper layer
--

data Status =
         InputEmpty
       | OutputFull
       | IncompleteChar
       | InvalidChar
       | UnexpectedError Errno

iconv :: IConv Status
iconv :: IConv Status
iconv = (ConversionDescriptor -> Buffers -> IO (Buffers, Status))
-> IConv Status
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, Status))
 -> IConv Status)
-> (ConversionDescriptor -> Buffers -> IO (Buffers, Status))
-> IConv Status
forall a b. (a -> b) -> a -> b
$ \(ConversionDescriptor cdfptr :: ForeignPtr ConversionDescriptor
cdfptr) bufs :: Buffers
bufs ->
  Bool -> IO (Buffers, Status) -> IO (Buffers, Status)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Buffers -> Int
outFree Buffers
bufs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO (Buffers, Status) -> IO (Buffers, Status))
-> IO (Buffers, Status) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$
  --TODO: optimise all this allocation
  ForeignPtr ConversionDescriptor
-> (Ptr ConversionDescriptor -> IO (Buffers, Status))
-> IO (Buffers, Status)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ConversionDescriptor
cdfptr                   ((Ptr ConversionDescriptor -> IO (Buffers, Status))
 -> IO (Buffers, Status))
-> (Ptr ConversionDescriptor -> IO (Buffers, Status))
-> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \cdPtr :: Ptr ConversionDescriptor
cdPtr ->
  ForeignPtr Word8
-> (Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Buffers -> ForeignPtr Word8
inBuffer Buffers
bufs)          ((Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \inBufPtr :: Ptr Word8
inBufPtr ->
  CString
-> (Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (Ptr Word8
inBufPtr Ptr Word8 -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Buffers -> Int
inOffset Buffers
bufs) ((Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \inBufPtrPtr :: Ptr CString
inBufPtrPtr ->
  CSize
-> (Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status)
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 (Buffers -> Int
inLength Buffers
bufs))     ((Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \inLengthPtr :: Ptr CSize
inLengthPtr ->
  ForeignPtr Word8
-> (Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Buffers -> ForeignPtr Word8
outBuffer Buffers
bufs)         ((Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr Word8 -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \outBufPtr :: Ptr Word8
outBufPtr ->
  let outBufPtr' :: Ptr b
outBufPtr' = Ptr Word8
outBufPtr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Buffers -> Int
outOffset Buffers
bufs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Buffers -> Int
outLength Buffers
bufs) in
  CString
-> (Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CString
forall a. Ptr a
outBufPtr'                         ((Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr CString -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \outBufPtrPtr :: Ptr CString
outBufPtrPtr ->
  CSize
-> (Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status)
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 (Buffers -> Int
outFree Buffers
bufs))      ((Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status))
-> (Ptr CSize -> IO (Buffers, Status)) -> IO (Buffers, Status)
forall a b. (a -> b) -> a -> b
$ \outFreePtr :: Ptr CSize
outFreePtr -> do

    CSize
result <- Ptr ConversionDescriptor
-> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CSize
c_iconv Ptr ConversionDescriptor
cdPtr Ptr CString
inBufPtrPtr Ptr CSize
inLengthPtr Ptr CString
outBufPtrPtr Ptr CSize
outFreePtr
    Int
inLength' <- CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
inLengthPtr
    Int
outFree'  <- CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
outFreePtr
    let inByteCount :: Int
inByteCount   = Buffers -> Int
inLength Buffers
bufs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
inLength'
        outByteCount :: Int
outByteCount  = Buffers -> Int
outFree Buffers
bufs  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
outFree'
        bufs' :: Buffers
bufs' = Buffers
bufs {
            inOffset :: Int
inOffset  = Buffers -> Int
inOffset Buffers
bufs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
inByteCount,
            inLength :: Int
inLength  = Int
inLength',
            inTotal :: Int
inTotal   = Buffers -> Int
inTotal Buffers
bufs   Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
inByteCount,
            outLength :: Int
outLength = Buffers -> Int
outLength Buffers
bufs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
outByteCount,
            outFree :: Int
outFree   = Int
outFree'
          }
    if CSize
result CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
/= CSize
errVal
      then (Buffers, Status) -> IO (Buffers, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs', Status
InputEmpty)
      else do Errno
errno <- IO Errno
getErrno
              case () of
                _ | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
e2BIG  -> (Buffers, Status) -> IO (Buffers, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs', Status
OutputFull)
                  | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINVAL -> (Buffers, Status) -> IO (Buffers, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs', Status
IncompleteChar)
                  | Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eILSEQ -> (Buffers, Status) -> IO (Buffers, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs', Status
InvalidChar)
                  | Bool
otherwise       -> (Buffers, Status) -> IO (Buffers, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs', Errno -> Status
UnexpectedError Errno
errno)

  where errVal :: CSize
        errVal :: CSize
errVal = (-1)   -- (size_t)(-1)

-- | This never needs to be used as the iconv descriptor will be released
-- automatically when no longer needed, however this can be used to release
-- it early. Only use this when you can guarantee that the iconv will no
-- longer be needed, for example if an error occurs or if the input stream
-- ends.
--
finalise :: IConv ()
finalise :: IConv ()
finalise = (ConversionDescriptor -> Buffers -> IO (Buffers, ())) -> IConv ()
forall a.
(ConversionDescriptor -> Buffers -> IO (Buffers, a)) -> IConv a
I ((ConversionDescriptor -> Buffers -> IO (Buffers, ())) -> IConv ())
-> (ConversionDescriptor -> Buffers -> IO (Buffers, ()))
-> IConv ()
forall a b. (a -> b) -> a -> b
$ \(ConversionDescriptor cd :: ForeignPtr ConversionDescriptor
cd) bufs :: Buffers
bufs -> do
  ForeignPtr ConversionDescriptor -> IO ()
forall a. ForeignPtr a -> IO ()
finalizeForeignPtr ForeignPtr ConversionDescriptor
cd
  (Buffers, ()) -> IO (Buffers, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffers
bufs, ())


----------------------
-- The foreign imports

newtype ConversionDescriptor = ConversionDescriptor (ForeignPtr ConversionDescriptor) -- iconv_t

foreign import ccall unsafe "hsiconv.h hs_wrap_iconv_open"
  c_iconv_open :: CString  -- to code
               -> CString  -- from code
               -> IO (Ptr ConversionDescriptor)

foreign import ccall unsafe "hsiconv.h hs_wrap_iconv"
  c_iconv :: Ptr ConversionDescriptor
          -> Ptr (Ptr CChar)  -- in buf
          -> Ptr CSize        -- in buf bytes left
          -> Ptr (Ptr CChar)  -- out buf
          -> Ptr CSize        -- out buf bytes left
          -> IO CSize

foreign import ccall unsafe "hsiconv.h &hs_wrap_iconv_close"
  c_iconv_close :: FinalizerPtr ConversionDescriptor