    {-# 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
        CString, CStringLen,

        -- 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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    -- | A C string is a reference to an array of C characters terminated by NUL.
    type CString    = Ptr CChar

    -- | A string with explicit length information in bytes instead of a
    -- terminating NUL (allowing NUL characters in the middle of the string).
    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 TextEncoding
    enc 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 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 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 :: forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
    withCString TextEncoding
    enc String
    s 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
    $ \(CString
    cp, 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 :: forall a. TextEncoding -> String -> (CStringLen -> IO a) -> IO a
    withCStringLen 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 :: forall a.
    TextEncoding -> [String] -> (Int -> Ptr CString -> IO a) -> IO a
    withCStringsLen TextEncoding
    enc [String]
    strs Int -> Ptr CString -> IO a
    f = [CString] -> [String] -> IO a
    go [] [String]
    strs
      where
      go :: [CString] -> [String] -> IO a
    go [CString]
    cs (String
    s:[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
    $ \CString
    c -> [CString] -> [String] -> IO a
    go (CString
    cCString -> [CString] -> [CString]
    forall a. a -> [a] -> [a]
    :[CString]
    cs) [String]
    ss
      go [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 Char
    c =
      TextEncoding -> String -> (CString -> IO Bool) -> IO Bool
    forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
    withCString TextEncoding
    enc [Char
    c]
                  (\CString
    cstr -> do String
    str <- TextEncoding -> CString -> IO String
    peekCString TextEncoding
    enc CString
    cstr
                               case String
    str of
                                 [Char
    ch] | Char
    ch Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    c -> Bool -> IO Bool
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    True
                                 String
    _ -> Bool -> IO Bool
    forall a. a -> IO a
    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 a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False

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

    -- C's end of string character
    nUL :: CChar
    nUL :: CChar
    nUL  = CChar
    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 }) (CString
    p, 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
    $ \TextDecoder dstate
    decoder -> do
          let chunk_size :: Int
    chunk_size = Int
    sz_bytes Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    `max` Int
    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 a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\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 Buffer Word8
    from = do
                (CodingProgress
    why, Buffer Word8
    from', 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 (String
    "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 -> String
    forall a. [a] -> [a] -> [a]
    ++ CodingProgress -> String
    forall a. Show a => a -> String
    show CodingProgress
    why)
                  (Buffer Word8
    from'', CharBuffer
    to'') <- case CodingProgress
    why of CodingProgress
    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
                                                CodingProgress
    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
                                                CodingProgress
    OutputUnderflow -> (Buffer Word8, CharBuffer) -> IO (Buffer Word8, CharBuffer)
    forall a. a -> IO a
    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 (String
    "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 -> 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 -> String
    forall a. [a] -> [a] -> [a]
    ++ Buffer Word8 -> String
    forall a. Buffer a -> String
    summaryBuffer Buffer Word8
    from'')
                  String -> IO ()
    putDebugMsg (String
    "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 -> 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 -> 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 a b. (a -> b) -> IO a -> IO b
    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
    + t
    1) Buffer Word8
    from''

          Int -> Buffer Word8 -> IO String
    forall {t}. (Show t, Num t) => t -> Buffer Word8 -> IO String
    go (Int
    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 :: forall a.
    TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
    withEncodedCString (TextEncoding { mkTextEncoder :: ()
    mkTextEncoder = IO (TextEncoder estate)
    mk_encoder }) Bool
    null_terminate String
    s 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
    $ \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
    $ \Int
    sz Ptr Char
    p -> do
          CharBuffer
    from <- (RawBuffer Char -> CharBuffer)
    -> IO (RawBuffer Char) -> IO CharBuffer
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\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 Int
    to_sz_bytes = do
               String -> IO ()
    putDebugMsg (String
    "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
    $ \Ptr Word8
    to_p -> do
                -- See Note [Check *before* fill in withEncodedCString] about why
                -- this is subtle.
                Maybe (Buffer Word8)
    mb_res <- TextEncoder estate
    -> Bool
    -> CharBuffer
    -> Ptr Word8
    -> Int
    -> IO (Maybe (Buffer Word8))
    forall dstate.
    TextEncoder dstate
    -> Bool
    -> CharBuffer
    -> Ptr Word8
    -> Int
    -> IO (Maybe (Buffer Word8))
    tryFillBuffer TextEncoder estate
    encoder Bool
    null_terminate CharBuffer
    from Ptr Word8
    to_p Int
    to_sz_bytes
                case Maybe (Buffer Word8)
    mb_res of
                  Maybe (Buffer Word8)
    Nothing  -> t -> Int -> IO a
    go (t
    iteration t -> t -> t
    forall a. Num a => a -> a -> a
    + t
    1) (Int
    to_sz_bytes Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    2)
                  Just Buffer Word8
    to_buf -> Buffer Word8 -> Bool -> (CStringLen -> IO a) -> IO a
    forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
    withCStringBuffer Buffer Word8
    to_buf Bool
    null_terminate CStringLen -> IO a
    act

          -- 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 (Int
    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
    + Int
    1))

    withCStringBuffer :: Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
    withCStringBuffer :: forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
    withCStringBuffer Buffer Word8
    to_buf Bool
    null_terminate CStringLen -> IO r
    act = do
      let bytes :: Int
    bytes = Buffer Word8 -> Int
    forall e. Buffer e -> Int
    bufferElems Buffer Word8
    to_buf
      Buffer Word8 -> (Ptr Word8 -> IO r) -> IO r
    forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
    withBuffer Buffer Word8
    to_buf ((Ptr Word8 -> IO r) -> IO r) -> (Ptr Word8 -> IO r) -> IO r
    forall a b. (a -> b) -> a -> b
    $ \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_buf) Word8
    0
        CStringLen -> IO r
    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*

    {-# 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 }) Bool
    null_terminate 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
    $ \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
    $ \Int
    sz Ptr Char
    p -> do
          CharBuffer
    from <- (RawBuffer Char -> CharBuffer)
    -> IO (RawBuffer Char) -> IO CharBuffer
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\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 Ptr Word8
    to_p Int
    to_sz_bytes = do
               String -> IO ()
    putDebugMsg (String
    "newEncodedCString: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ t -> String
    forall a. Show a => a -> String
    show t
    iteration)
               Maybe (Buffer Word8)
    mb_res <- TextEncoder estate
    -> Bool
    -> CharBuffer
    -> Ptr Word8
    -> Int
    -> IO (Maybe (Buffer Word8))
    forall dstate.
    TextEncoder dstate
    -> Bool
    -> CharBuffer
    -> Ptr Word8
    -> Int
    -> IO (Maybe (Buffer Word8))
    tryFillBuffer TextEncoder estate
    encoder Bool
    null_terminate CharBuffer
    from Ptr Word8
    to_p Int
    to_sz_bytes
               case Maybe (Buffer Word8)
    mb_res of
                 Maybe (Buffer Word8)
    Nothing  -> do
                     let to_sz_bytes' :: Int
    to_sz_bytes' = Int
    to_sz_bytes Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    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
    + t
    1) Ptr Word8
    to_p' Int
    to_sz_bytes'
                 Just Buffer Word8
    to_buf -> Buffer Word8
    -> Bool -> (CStringLen -> IO CStringLen) -> IO CStringLen
    forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
    withCStringBuffer Buffer Word8
    to_buf Bool
    null_terminate CStringLen -> IO CStringLen
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

          -- 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
    + Int
    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 (Int
    0 :: Int) Ptr Word8
    to_p Int
    to_sz_bytes

    tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
                        ->  IO (Maybe (Buffer Word8))
    tryFillBuffer :: forall dstate.
    TextEncoder dstate
    -> Bool
    -> CharBuffer
    -> Ptr Word8
    -> Int
    -> IO (Maybe (Buffer Word8))
    tryFillBuffer TextEncoder dstate
    encoder Bool
    null_terminate CharBuffer
    from0 Ptr Word8
    to_p Int
    to_sz_bytes = 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 (Buffer Word8))
    forall {t}.
    (Show t, Num t) =>
    t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
    go (Int
    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 :: t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
    go !t
    iteration (CharBuffer
    from, Buffer Word8
    to) = do
          (CodingProgress
    why, CharBuffer
    from', 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 (String
    "tryFillBufferAndCall: " 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 -> 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 -> 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 -> 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
    == Int
    0
                 then Maybe (Buffer Word8) -> IO (Maybe (Buffer Word8))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Buffer Word8)
    forall a. Maybe a
    Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer
                 else Maybe (Buffer Word8) -> IO (Maybe (Buffer Word8))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Buffer Word8 -> Maybe (Buffer Word8)
    forall a. a -> Maybe a
    Just Buffer Word8
    to')
           else case CodingProgress
    why of -- We didn't consume all of the input
                  CodingProgress
    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 (Buffer Word8)))
    -> IO (Maybe (Buffer Word8))
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
    go (t
    iteration t -> t -> t
    forall a. Num a => a -> a -> a
    + t
    1) -- These conditions are equally bad
                  CodingProgress
    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 (Buffer Word8)))
    -> IO (Maybe (Buffer Word8))
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
    go (t
    iteration t -> t -> t
    forall a. Num a => a -> a -> a
    + t
    1) -- since the input was truncated/invalid
                  CodingProgress
    OutputUnderflow -> Maybe (Buffer Word8) -> IO (Maybe (Buffer Word8))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Buffer Word8)
    forall a. Maybe a
    Nothing -- Oops, out of buffer during decoding: ask the caller for more
    {-
    Note [Check *before* fill in withEncodedCString]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It's very important that the size check and readjustment peformed by tryFillBuffer
    happens before the continuation is called. The size check is the part which can
    fail, the call to the continuation never fails and so the caller should respond
    first to the size check failing and *then* call the continuation. Making this evident
    to the compiler avoids historic space leaks.

    In a previous iteration of this code we had a pattern that, somewhat simplified,
    looked like this:

    go :: State -> (State -> IO a) -> IO a
    go state action =
        case tryFillBufferAndCall state action of
            Left state' -> go state' action
            Right result -> result

    `tryFillBufferAndCall` performed some checks, and then we either called action,
    or we modified the state and tried again.
    This went wrong because `action` can be a function closure containing a reference to
    a lazy data structure. If we call action directly, without retaining any references
    to action, that is fine. The data structure is consumed as it is produced and we operate
    in constant space.

    However the failure branch `go state' action` *does* capture a reference to action.
    This went wrong because the reference to action in the failure branch only becomes
    unreachable *after* action returns. This means we keep alive the function closure
    for `action` until `action` returns. Which in turn keeps alive the *whole* lazy list
    via `action` until the action has fully run.
    This went wrong in #20107, where the continuation kept an entire lazy bytestring alive
    rather than allowing it to be incrementally consumed and collected.
    -}