{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Foreign
-- Copyright   :  (c) The University of Glasgow, 2008-2011
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Foreign marshalling support for CStrings with configurable encodings
--
-----------------------------------------------------------------------------

module GHC.Foreign (
    -- * C strings with a configurable encoding

    -- conversion of C strings into Haskell strings
    --
    peekCString,
    peekCStringLen,

    -- conversion of Haskell strings into C strings
    --
    newCString,
    newCStringLen,

    -- conversion of Haskell strings into C strings using temporary storage
    --
    withCString,
    withCStringLen,
    withCStringsLen,

    charIsRepresentable,
  ) where

import Foreign.Marshal.Array
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable

import Data.Word

-- Imports for the locale-encoding version of marshallers

import Data.Tuple (fst)

import GHC.Show ( show )

import Foreign.Marshal.Alloc
import Foreign.ForeignPtr

import GHC.Debug
import GHC.List
import GHC.Num
import GHC.Base

import GHC.IO
import GHC.IO.Exception
import GHC.IO.Buffer
import GHC.IO.Encoding.Types


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

putDebugMsg :: String -> IO ()
putDebugMsg :: String -> IO ()
putDebugMsg | Bool
c_DEBUG_DUMP = String -> IO ()
debugLn
            | Bool
otherwise    = IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())


-- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:
type CString    = Ptr CChar
type CStringLen = (Ptr CChar, Int)

-- exported functions
-- ------------------

-- | Marshal a NUL terminated C string into a Haskell string.
--
peekCString    :: TextEncoding -> CString -> IO String
peekCString :: TextEncoding -> CString -> IO String
peekCString enc :: TextEncoding
enc cp :: CString
cp = do
    Int
sz <- CChar -> CString -> IO Int
forall a. (Storable a, Eq a) => a -> Ptr a -> IO Int
lengthArray0 CChar
nUL CString
cp
    TextEncoding -> CStringLen -> IO String
peekEncodedCString TextEncoding
enc (CString
cp, Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cCharSize)

-- | Marshal a C string with explicit length into a Haskell string.
--
peekCStringLen           :: TextEncoding -> CStringLen -> IO String
peekCStringLen :: TextEncoding -> CStringLen -> IO String
peekCStringLen = TextEncoding -> CStringLen -> IO String
peekEncodedCString

-- | Marshal a Haskell string into a NUL terminated C string.
--
-- * the Haskell string may /not/ contain any NUL characters
--
-- * new storage is allocated for the C string and must be
--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
--   'Foreign.Marshal.Alloc.finalizerFree'.
--
newCString :: TextEncoding -> String -> IO CString
newCString :: TextEncoding -> String -> IO CString
newCString enc :: TextEncoding
enc = (CStringLen -> CString) -> IO CStringLen -> IO CString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CStringLen -> CString
forall a b. (a, b) -> a
fst (IO CStringLen -> IO CString)
-> (String -> IO CStringLen) -> String -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString TextEncoding
enc Bool
True

-- | Marshal a Haskell string into a C string (ie, character array) with
-- explicit length information.
--
-- * new storage is allocated for the C string and must be
--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
--   'Foreign.Marshal.Alloc.finalizerFree'.
--
newCStringLen     :: TextEncoding -> String -> IO CStringLen
newCStringLen :: TextEncoding -> String -> IO CStringLen
newCStringLen enc :: TextEncoding
enc = TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString TextEncoding
enc Bool
False

-- | Marshal a Haskell string into a NUL terminated C string using temporary
-- storage.
--
-- * the Haskell string may /not/ contain any NUL characters
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a
withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a
withCString enc :: TextEncoding
enc s :: String
s act :: CString -> IO a
act = TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
forall a.
TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString TextEncoding
enc Bool
True String
s ((CStringLen -> IO a) -> IO a) -> (CStringLen -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(cp :: CString
cp, _sz :: Int
_sz) -> CString -> IO a
act CString
cp

-- | Marshal a Haskell string into a C string (ie, character array)
-- in temporary storage, with explicit length information.
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCStringLen         :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
withCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
withCStringLen enc :: TextEncoding
enc = TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
forall a.
TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString TextEncoding
enc Bool
False

-- | Marshal a list of Haskell strings into an array of NUL terminated C strings
-- using temporary storage.
--
-- * the Haskell strings may /not/ contain any NUL characters
--
-- * the memory is freed when the subcomputation terminates (either
--   normally or via an exception), so the pointer to the temporary
--   storage must /not/ be used after this.
--
withCStringsLen :: TextEncoding
                -> [String]
                -> (Int -> Ptr CString -> IO a)
                -> IO a
withCStringsLen :: TextEncoding -> [String] -> (Int -> Ptr CString -> IO a) -> IO a
withCStringsLen enc :: TextEncoding
enc strs :: [String]
strs f :: Int -> Ptr CString -> IO a
f = [CString] -> [String] -> IO a
go [] [String]
strs
  where
  go :: [CString] -> [String] -> IO a
go cs :: [CString]
cs (s :: String
s:ss :: [String]
ss) = TextEncoding -> String -> (CString -> IO a) -> IO a
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
s ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \c :: CString
c -> [CString] -> [String] -> IO a
go (CString
cCString -> [CString] -> [CString]
forall a. a -> [a] -> [a]
:[CString]
cs) [String]
ss
  go cs :: [CString]
cs [] = [CString] -> (Int -> Ptr CString -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ([CString] -> [CString]
forall a. [a] -> [a]
reverse [CString]
cs) Int -> Ptr CString -> IO a
f

-- | Determines whether a character can be accurately encoded in a
-- 'Foreign.C.String.CString'.
--
-- Pretty much anyone who uses this function is in a state of sin because
-- whether or not a character is encodable will, in general, depend on the
-- context in which it occurs.
charIsRepresentable :: TextEncoding -> Char -> IO Bool
-- We force enc explicitly because `catch` is lazy in its
-- first argument. We would probably like to force c as well,
-- but unfortunately worker/wrapper produces very bad code for
-- that.
--
-- TODO If this function is performance-critical, it would probably
-- pay to use a single-character specialization of withCString. That
-- would allow worker/wrapper to actually eliminate Char boxes, and
-- would also get rid of the completely unnecessary cons allocation.
charIsRepresentable :: TextEncoding -> Char -> IO Bool
charIsRepresentable !TextEncoding
enc c :: Char
c =
  TextEncoding -> String -> (CString -> IO Bool) -> IO Bool
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc [Char
c]
              (\cstr :: CString
cstr -> do String
str <- TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cstr
                           case String
str of
                             [ch :: Char
ch] | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                             _ -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
    IO Bool -> (IOException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
       \(IOException
_ :: IOException) -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- auxiliary definitions
-- ----------------------

-- C's end of string character
nUL :: CChar
nUL :: CChar
nUL  = 0

-- Size of a CChar in bytes
cCharSize :: Int
cCharSize :: Int
cCharSize = CChar -> Int
forall a. Storable a => a -> Int
sizeOf (CChar
forall a. HasCallStack => a
undefined :: CChar)


{-# INLINE peekEncodedCString #-}
peekEncodedCString :: TextEncoding -- ^ Encoding of CString
                   -> CStringLen
                   -> IO String    -- ^ String in Haskell terms
peekEncodedCString :: TextEncoding -> CStringLen -> IO String
peekEncodedCString (TextEncoding { mkTextDecoder :: ()
mkTextDecoder = IO (TextDecoder dstate)
mk_decoder }) (p :: CString
p, sz_bytes :: Int
sz_bytes)
  = IO (TextDecoder dstate)
-> (TextDecoder dstate -> IO ())
-> (TextDecoder dstate -> IO String)
-> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextDecoder dstate)
mk_decoder TextDecoder dstate -> IO ()
forall from to state. BufferCodec from to state -> IO ()
close ((TextDecoder dstate -> IO String) -> IO String)
-> (TextDecoder dstate -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \decoder :: TextDecoder dstate
decoder -> do
      let chunk_size :: Int
chunk_size = Int
sz_bytes Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII
      Buffer Word8
from0 <- (RawBuffer Word8 -> Buffer Word8)
-> IO (RawBuffer Word8) -> IO (Buffer Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\fp :: RawBuffer Word8
fp -> Int -> Buffer Word8 -> Buffer Word8
forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz_bytes (RawBuffer Word8 -> Int -> BufferState -> Buffer Word8
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Word8
fp Int
sz_bytes BufferState
ReadBuffer)) (IO (RawBuffer Word8) -> IO (Buffer Word8))
-> IO (RawBuffer Word8) -> IO (Buffer Word8)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (RawBuffer Word8)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
p)
      CharBuffer
to <- Int -> BufferState -> IO CharBuffer
newCharBuffer Int
chunk_size BufferState
WriteBuffer

      let go :: t -> Buffer Word8 -> IO String
go !t
iteration from :: Buffer Word8
from = do
            (why :: CodingProgress
why, from' :: Buffer Word8
from', to' :: CharBuffer
to') <- TextDecoder dstate -> CodeBuffer Word8 Char
forall from to state.
BufferCodec from to state -> CodeBuffer from to
encode TextDecoder dstate
decoder Buffer Word8
from CharBuffer
to
            if Buffer Word8 -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
from'
             then
              -- No input remaining: @why@ will be InputUnderflow, but we don't care
              CharBuffer -> (Ptr Char -> IO String) -> IO String
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer CharBuffer
to' ((Ptr Char -> IO String) -> IO String)
-> (Ptr Char -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> Ptr Char -> IO String
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CharBuffer -> Int
forall e. Buffer e -> Int
bufferElems CharBuffer
to')
             else do
              -- Input remaining: what went wrong?
              String -> IO ()
putDebugMsg ("peekEncodedCString: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
iteration String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
why)
              (from'' :: Buffer Word8
from'', to'' :: CharBuffer
to'') <- case CodingProgress
why of InvalidSequence -> TextDecoder dstate
-> Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)
forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextDecoder dstate
decoder Buffer Word8
from' CharBuffer
to' -- These conditions are equally bad because
                                            InputUnderflow  -> TextDecoder dstate
-> Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)
forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextDecoder dstate
decoder Buffer Word8
from' CharBuffer
to' -- they indicate malformed/truncated input
                                            OutputUnderflow -> (Buffer Word8, CharBuffer) -> IO (Buffer Word8, CharBuffer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Word8
from', CharBuffer
to')       -- We will have more space next time round
              String -> IO ()
putDebugMsg ("peekEncodedCString: from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
from' String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Buffer Word8 -> String
forall a. Buffer a -> String
summaryBuffer Buffer Word8
from'')
              String -> IO ()
putDebugMsg ("peekEncodedCString: to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharBuffer -> String
forall a. Buffer a -> String
summaryBuffer CharBuffer
to String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharBuffer -> String
forall a. Buffer a -> String
summaryBuffer CharBuffer
to' String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharBuffer -> String
forall a. Buffer a -> String
summaryBuffer CharBuffer
to'')
              String
to_chars <- CharBuffer -> (Ptr Char -> IO String) -> IO String
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer CharBuffer
to'' ((Ptr Char -> IO String) -> IO String)
-> (Ptr Char -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> Ptr Char -> IO String
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CharBuffer -> Int
forall e. Buffer e -> Int
bufferElems CharBuffer
to'')
              (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
to_charsString -> String -> String
forall a. [a] -> [a] -> [a]
++) (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ t -> Buffer Word8 -> IO String
go (t
iteration t -> t -> t
forall a. Num a => a -> a -> a
+ 1) Buffer Word8
from''

      Int -> Buffer Word8 -> IO String
forall t. (Show t, Num t) => t -> Buffer Word8 -> IO String
go (0 :: Int) Buffer Word8
from0

{-# INLINE withEncodedCString #-}
withEncodedCString :: TextEncoding         -- ^ Encoding of CString to create
                   -> Bool                 -- ^ Null-terminate?
                   -> String               -- ^ String to encode
                   -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory
                   -> IO a
withEncodedCString :: TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString (TextEncoding { mkTextEncoder :: ()
mkTextEncoder = IO (TextEncoder estate)
mk_encoder }) null_terminate :: Bool
null_terminate s :: String
s act :: CStringLen -> IO a
act
  = IO (TextEncoder estate)
-> (TextEncoder estate -> IO ())
-> (TextEncoder estate -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextEncoder estate)
mk_encoder TextEncoder estate -> IO ()
forall from to state. BufferCodec from to state -> IO ()
close ((TextEncoder estate -> IO a) -> IO a)
-> (TextEncoder estate -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \encoder :: TextEncoder estate
encoder -> String -> (Int -> Ptr Char -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen String
s ((Int -> Ptr Char -> IO a) -> IO a)
-> (Int -> Ptr Char -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \sz :: Int
sz p :: Ptr Char
p -> do
      CharBuffer
from <- (RawBuffer Char -> CharBuffer)
-> IO (RawBuffer Char) -> IO CharBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\fp :: RawBuffer Char
fp -> Int -> CharBuffer -> CharBuffer
forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz (RawBuffer Char -> Int -> BufferState -> CharBuffer
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Char
fp Int
sz BufferState
ReadBuffer)) (IO (RawBuffer Char) -> IO CharBuffer)
-> IO (RawBuffer Char) -> IO CharBuffer
forall a b. (a -> b) -> a -> b
$ Ptr Char -> IO (RawBuffer Char)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Char
p

      let go :: t -> Int -> IO a
go !t
iteration to_sz_bytes :: Int
to_sz_bytes = do
           String -> IO ()
putDebugMsg ("withEncodedCString: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
iteration)
           Int -> (Ptr Word8 -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
to_sz_bytes ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \to_p :: Ptr Word8
to_p -> do
            Maybe a
mb_res <- TextEncoder estate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> (CStringLen -> IO a)
-> IO (Maybe a)
forall dstate a.
TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> (CStringLen -> IO a)
-> IO (Maybe a)
tryFillBufferAndCall TextEncoder estate
encoder Bool
null_terminate CharBuffer
from Ptr Word8
to_p Int
to_sz_bytes CStringLen -> IO a
act
            case Maybe a
mb_res of
              Nothing  -> t -> Int -> IO a
go (t
iteration t -> t -> t
forall a. Num a => a -> a -> a
+ 1) (Int
to_sz_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2)
              Just res :: a
res -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

      -- If the input string is ASCII, this value will ensure we only allocate once
      Int -> Int -> IO a
forall t. (Show t, Num t) => t -> Int -> IO a
go (0 :: Int) (Int
cCharSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))

{-# INLINE newEncodedCString #-}
newEncodedCString :: TextEncoding  -- ^ Encoding of CString to create
                  -> Bool          -- ^ Null-terminate?
                  -> String        -- ^ String to encode
                  -> IO CStringLen
newEncodedCString :: TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString (TextEncoding { mkTextEncoder :: ()
mkTextEncoder = IO (TextEncoder estate)
mk_encoder }) null_terminate :: Bool
null_terminate s :: String
s
  = IO (TextEncoder estate)
-> (TextEncoder estate -> IO ())
-> (TextEncoder estate -> IO CStringLen)
-> IO CStringLen
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextEncoder estate)
mk_encoder TextEncoder estate -> IO ()
forall from to state. BufferCodec from to state -> IO ()
close ((TextEncoder estate -> IO CStringLen) -> IO CStringLen)
-> (TextEncoder estate -> IO CStringLen) -> IO CStringLen
forall a b. (a -> b) -> a -> b
$ \encoder :: TextEncoder estate
encoder -> String -> (Int -> Ptr Char -> IO CStringLen) -> IO CStringLen
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen String
s ((Int -> Ptr Char -> IO CStringLen) -> IO CStringLen)
-> (Int -> Ptr Char -> IO CStringLen) -> IO CStringLen
forall a b. (a -> b) -> a -> b
$ \sz :: Int
sz p :: Ptr Char
p -> do
      CharBuffer
from <- (RawBuffer Char -> CharBuffer)
-> IO (RawBuffer Char) -> IO CharBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\fp :: RawBuffer Char
fp -> Int -> CharBuffer -> CharBuffer
forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz (RawBuffer Char -> Int -> BufferState -> CharBuffer
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Char
fp Int
sz BufferState
ReadBuffer)) (IO (RawBuffer Char) -> IO CharBuffer)
-> IO (RawBuffer Char) -> IO CharBuffer
forall a b. (a -> b) -> a -> b
$ Ptr Char -> IO (RawBuffer Char)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Char
p

      let go :: t -> Ptr Word8 -> Int -> IO CStringLen
go !t
iteration to_p :: Ptr Word8
to_p to_sz_bytes :: Int
to_sz_bytes = do
           String -> IO ()
putDebugMsg ("newEncodedCString: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
iteration)
           Maybe CStringLen
mb_res <- TextEncoder estate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> (CStringLen -> IO CStringLen)
-> IO (Maybe CStringLen)
forall dstate a.
TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> (CStringLen -> IO a)
-> IO (Maybe a)
tryFillBufferAndCall TextEncoder estate
encoder Bool
null_terminate CharBuffer
from Ptr Word8
to_p Int
to_sz_bytes CStringLen -> IO CStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return
           case Maybe CStringLen
mb_res of
             Nothing  -> do
                 let to_sz_bytes' :: Int
to_sz_bytes' = Int
to_sz_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2
                 Ptr Word8
to_p' <- Ptr Word8 -> Int -> IO (Ptr Word8)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
to_p Int
to_sz_bytes'
                 t -> Ptr Word8 -> Int -> IO CStringLen
go (t
iteration t -> t -> t
forall a. Num a => a -> a -> a
+ 1) Ptr Word8
to_p' Int
to_sz_bytes'
             Just res :: CStringLen
res -> CStringLen -> IO CStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return CStringLen
res

      -- If the input string is ASCII, this value will ensure we only allocate once
      let to_sz_bytes :: Int
to_sz_bytes = Int
cCharSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      Ptr Word8
to_p <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
to_sz_bytes
      Int -> Ptr Word8 -> Int -> IO CStringLen
forall t. (Show t, Num t) => t -> Ptr Word8 -> Int -> IO CStringLen
go (0 :: Int) Ptr Word8
to_p Int
to_sz_bytes


tryFillBufferAndCall :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
                     -> (CStringLen -> IO a) -> IO (Maybe a)
tryFillBufferAndCall :: TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> (CStringLen -> IO a)
-> IO (Maybe a)
tryFillBufferAndCall encoder :: TextEncoder dstate
encoder null_terminate :: Bool
null_terminate from0 :: CharBuffer
from0 to_p :: Ptr Word8
to_p to_sz_bytes :: Int
to_sz_bytes act :: CStringLen -> IO a
act = do
    RawBuffer Word8
to_fp <- Ptr Word8 -> IO (RawBuffer Word8)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Word8
to_p
    Int -> (CharBuffer, Buffer Word8) -> IO (Maybe a)
forall a.
(Show a, Num a) =>
a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)
go (0 :: Int) (CharBuffer
from0, RawBuffer Word8 -> Int -> BufferState -> Buffer Word8
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Word8
to_fp Int
to_sz_bytes BufferState
WriteBuffer)
  where
    go :: a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)
go !a
iteration (from :: CharBuffer
from, to :: Buffer Word8
to) = do
      (why :: CodingProgress
why, from' :: CharBuffer
from', to' :: Buffer Word8
to') <- TextEncoder dstate -> CodeBuffer Char Word8
forall from to state.
BufferCodec from to state -> CodeBuffer from to
encode TextEncoder dstate
encoder CharBuffer
from Buffer Word8
to
      String -> IO ()
putDebugMsg ("tryFillBufferAndCall: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
iteration String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodingProgress -> String
forall a. Show a => a -> String
show CodingProgress
why String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharBuffer -> String
forall a. Buffer a -> String
summaryBuffer CharBuffer
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharBuffer -> String
forall a. Buffer a -> String
summaryBuffer CharBuffer
from')
      if CharBuffer -> Bool
forall e. Buffer e -> Bool
isEmptyBuffer CharBuffer
from'
       then if Bool
null_terminate Bool -> Bool -> Bool
&& Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferAvailable Buffer Word8
to' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
             then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer
             else do
               -- Awesome, we had enough buffer
               let bytes :: Int
bytes = Buffer Word8 -> Int
forall e. Buffer e -> Int
bufferElems Buffer Word8
to'
               Buffer Word8 -> (Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
to' ((Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \to_ptr :: Ptr Word8
to_ptr -> do
                   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
null_terminate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
to_ptr (Buffer Word8 -> Int
forall e. Buffer e -> Int
bufR Buffer Word8
to') 0
                   (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ CStringLen -> IO a
act (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
to_ptr, Int
bytes) -- NB: the length information is specified as being in *bytes*
       else case CodingProgress
why of -- We didn't consume all of the input
              InputUnderflow  -> TextEncoder dstate
-> CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)
forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextEncoder dstate
encoder CharBuffer
from' Buffer Word8
to' IO (CharBuffer, Buffer Word8)
-> ((CharBuffer, Buffer Word8) -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)
go (a
iteration a -> a -> a
forall a. Num a => a -> a -> a
+ 1) -- These conditions are equally bad
              InvalidSequence -> TextEncoder dstate
-> CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)
forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextEncoder dstate
encoder CharBuffer
from' Buffer Word8
to' IO (CharBuffer, Buffer Word8)
-> ((CharBuffer, Buffer Word8) -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)
go (a
iteration a -> a -> a
forall a. Num a => a -> a -> a
+ 1) -- since the input was truncated/invalid
              OutputUnderflow -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing -- Oops, out of buffer during decoding: ask the caller for more