    {-# OPTIONS_GHC -fno-implicit-prelude #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Foreign.C.String
    -- Copyright   :  (c) The FFI task force 2001
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  ffi@haskell.org
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- Utilities for primitive marshalling of C strings.
    --
    -- The marshalling converts each Haskell character, representing a Unicode
    -- code point, to one or more bytes in a manner that, by default, is
    -- determined by the current locale.  As a consequence, no guarantees
    -- can be made about the relative length of a Haskell string and its
    -- corresponding C string, and therefore all the marshalling routines
    -- include memory allocation.  The translation between Unicode and the
    -- encoding of the current locale may be lossy.
    --
    -----------------------------------------------------------------------------

    module Foreign.C.String (   -- representation of strings in C

      -- * C strings

      CString,           -- = Ptr CChar
      CStringLen,        -- = (Ptr CChar, Int)

      -- ** Using a locale-dependent encoding

      -- | Currently these functions are identical to their @CAString@ counterparts;
      -- eventually they will use an encoding determined by the current locale.

      -- conversion of C strings into Haskell strings
      --
      peekCString,       -- :: CString    -> IO String
      peekCStringLen,    -- :: CStringLen -> IO String

      -- conversion of Haskell strings into C strings
      --
      newCString,        -- :: String -> IO CString
      newCStringLen,     -- :: String -> IO CStringLen

      -- conversion of Haskell strings into C strings using temporary storage
      --
      withCString,       -- :: String -> (CString    -> IO a) -> IO a
      withCStringLen,    -- :: String -> (CStringLen -> IO a) -> IO a

      charIsRepresentable, -- :: Char -> IO Bool

      -- ** Using 8-bit characters

      -- | These variants of the above functions are for use with C libraries
      -- that are ignorant of Unicode.  These functions should be used with
      -- care, as a loss of information can occur.

      castCharToCChar,   -- :: Char -> CChar
      castCCharToChar,   -- :: CChar -> Char

      peekCAString,      -- :: CString    -> IO String
      peekCAStringLen,   -- :: CStringLen -> IO String
      newCAString,       -- :: String -> IO CString
      newCAStringLen,    -- :: String -> IO CStringLen
      withCAString,      -- :: String -> (CString    -> IO a) -> IO a
      withCAStringLen,   -- :: String -> (CStringLen -> IO a) -> IO a

      -- * C wide strings

      -- | These variants of the above functions are for use with C libraries
      -- that encode Unicode using the C @wchar_t@ type in a system-dependent
      -- way.  The only encodings supported are
      --
      -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or
      --
      -- * UTF-16 (as used on Windows systems).

      CWString,          -- = Ptr CWchar
      CWStringLen,       -- = (Ptr CWchar, Int)

      peekCWString,      -- :: CWString    -> IO String
      peekCWStringLen,   -- :: CWStringLen -> IO String
      newCWString,       -- :: String -> IO CWString
      newCWStringLen,    -- :: String -> IO CWStringLen
      withCWString,      -- :: String -> (CWString    -> IO a) -> IO a
      withCWStringLen,   -- :: String -> (CWStringLen -> IO a) -> IO a

      ) where

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

    import Data.Word

    #ifdef __GLASGOW_HASKELL__
    import GHC.List
    import GHC.Real
    import GHC.Num
    import GHC.IOBase
    import GHC.Base
    #else
    import Data.Char ( chr, ord )
    #define unsafeChr chr
    #endif

    -----------------------------------------------------------------------------
    -- Strings

    -- representation of strings in C
    -- ------------------------------

    -- | 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
    -- ------------------
    --
    -- * the following routines apply the default conversion when converting the
    --   C-land character encoding into the Haskell-land character encoding

    -- | Marshal a NUL terminated C string into a Haskell string.
    --
    peekCString    :: CString -> IO String
    peekCString = peekCAString

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

    -- | 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 :: String -> IO CString
    newCString = newCAString

    -- | 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     :: String -> IO CStringLen
    newCStringLen = newCAStringLen

    -- | 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 :: String -> (CString -> IO a) -> IO a
    withCString = withCAString

    -- | 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         :: String -> (CStringLen -> IO a) -> IO a
    withCStringLen = withCAStringLen

    -- | Determines whether a character can be accurately encoded in a 'CString'.
    -- Unrepresentable characters are converted to @\'?\'@.
    --
    -- Currently only Latin-1 characters are representable.
    charIsRepresentable :: Char -> IO Bool
    charIsRepresentable c = return (ord c < 256)

    -- single byte characters
    -- ----------------------
    --
    --   ** NOTE: These routines don't handle conversions! **

    -- | Convert a C byte, representing a Latin-1 character, to the corresponding
    -- Haskell character.
    castCCharToChar :: CChar -> Char
    castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))

    -- | Convert a Haskell character to a C character.
    -- This function is only safe on the first 256 characters.
    castCharToCChar :: Char -> CChar
    castCharToCChar ch = fromIntegral (ord ch)

    -- | Marshal a NUL terminated C string into a Haskell string.
    --
    peekCAString    :: CString -> IO String
    #ifndef __GLASGOW_HASKELL__
    peekCAString cp  = do
      cs <- peekArray0 nUL cp
      return (cCharsToChars cs)
    #else
    peekCAString cp = do
      l <- lengthArray0 nUL cp
      if l <= 0 then return "" else loop "" (l-1)
      where
        loop s i = do
            xval <- peekElemOff cp i
    	let val = castCCharToChar xval
    	val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)
    #endif

    -- | Marshal a C string with explicit length into a Haskell string.
    --
    peekCAStringLen           :: CStringLen -> IO String
    #ifndef __GLASGOW_HASKELL__
    peekCAStringLen (cp, len)  = do
      cs <- peekArray len cp
      return (cCharsToChars cs)
    #else
    peekCAStringLen (cp, len)
      | len <= 0  = return "" -- being (too?) nice.
      | otherwise = loop [] (len-1)
      where
        loop acc i = do
             xval <- peekElemOff cp i
    	 let val = castCCharToChar xval
    	   -- blow away the coercion ASAP.
    	 if (val `seq` (i == 0))
    	  then return (val:acc)
    	  else loop (val:acc) (i-1)
    #endif

    -- | 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'.
    --
    newCAString :: String -> IO CString
    #ifndef __GLASGOW_HASKELL__
    newCAString  = newArray0 nUL . charsToCChars
    #else
    newCAString str = do
      ptr <- mallocArray0 (length str)
      let
    	go [] n     = pokeElemOff ptr n nUL
        	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
      go str 0
      return ptr
    #endif

    -- | 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'.
    --
    newCAStringLen     :: String -> IO CStringLen
    #ifndef __GLASGOW_HASKELL__
    newCAStringLen str  = do
      a <- newArray (charsToCChars str)
      return (pairLength str a)
    #else
    newCAStringLen str = do
      ptr <- mallocArray0 len
      let
    	go [] n     = n `seq` return ()	-- make it strict in n
        	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
      go str 0
      return (ptr, len)
      where
        len = length str
    #endif

    -- | 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.
    --
    withCAString :: String -> (CString -> IO a) -> IO a
    #ifndef __GLASGOW_HASKELL__
    withCAString  = withArray0 nUL . charsToCChars
    #else
    withCAString str f =
      allocaArray0 (length str) $ \ptr ->
          let
    	go [] n     = pokeElemOff ptr n nUL
        	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
          in do
          go str 0
          f ptr
    #endif

    -- | 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.
    --
    withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a
    #ifndef __GLASGOW_HASKELL__
    withCAStringLen str act  = withArray (charsToCChars str) $ act . pairLength str
    #else
    withCAStringLen str f =
      allocaArray len $ \ptr ->
          let
    	go [] n     = n `seq` return ()	-- make it strict in n
        	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
          in do
          go str 0
          f (ptr,len)
      where
        len = length str
    #endif

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

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

    -- pair a C string with the length of the given Haskell string
    --
    pairLength :: String -> a -> (a, Int)
    pairLength  = flip (,) . length

    #ifndef __GLASGOW_HASKELL__
    -- cast [CChar] to [Char]
    --
    cCharsToChars :: [CChar] -> [Char]
    cCharsToChars xs  = map castCCharToChar xs

    -- cast [Char] to [CChar]
    --
    charsToCChars :: [Char] -> [CChar]
    charsToCChars xs  = map castCharToCChar xs
    #endif

    -----------------------------------------------------------------------------
    -- Wide strings

    -- representation of wide strings in C
    -- -----------------------------------

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

    -- | A wide character string with explicit length information in 'CWchar's
    -- instead of a terminating NUL (allowing NUL characters in the middle
    -- of the string).
    type CWStringLen = (Ptr CWchar, Int)

    -- | Marshal a NUL terminated C wide string into a Haskell string.
    --
    peekCWString    :: CWString -> IO String
    peekCWString cp  = do
      cs <- peekArray0 wNUL cp
      return (cWcharsToChars cs)

    -- | Marshal a C wide string with explicit length into a Haskell string.
    --
    peekCWStringLen           :: CWStringLen -> IO String
    peekCWStringLen (cp, len)  = do
      cs <- peekArray len cp
      return (cWcharsToChars cs)

    -- | Marshal a Haskell string into a NUL terminated C wide string.
    --
    -- * the Haskell string may /not/ contain any NUL characters
    --
    -- * new storage is allocated for the C wide string and must
    --   be explicitly freed using 'Foreign.Marshal.Alloc.free' or
    --   'Foreign.Marshal.Alloc.finalizerFree'.
    --
    newCWString :: String -> IO CWString
    newCWString  = newArray0 wNUL . charsToCWchars

    -- | Marshal a Haskell string into a C wide string (ie, wide character array)
    -- with explicit length information.
    --
    -- * new storage is allocated for the C wide string and must
    --   be explicitly freed using 'Foreign.Marshal.Alloc.free' or
    --   'Foreign.Marshal.Alloc.finalizerFree'.
    --
    newCWStringLen     :: String -> IO CWStringLen
    newCWStringLen str  = do
      a <- newArray (charsToCWchars str)
      return (pairLength str a)

    -- | Marshal a Haskell string into a NUL terminated C wide 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.
    --
    withCWString :: String -> (CWString -> IO a) -> IO a
    withCWString  = withArray0 wNUL . charsToCWchars

    -- | Marshal a Haskell string into a NUL terminated C wide 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.
    --
    withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a
    withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str

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

    wNUL :: CWchar
    wNUL = 0

    cWcharsToChars :: [CWchar] -> [Char]
    charsToCWchars :: [Char] -> [CWchar]

    #ifdef mingw32_HOST_OS

    -- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.

    -- coding errors generate Chars in the surrogate range
    cWcharsToChars = map chr . fromUTF16 . map fromIntegral
     where
      fromUTF16 (c1:c2:wcs)
        | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
          ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
      fromUTF16 (c:wcs) = c : fromUTF16 wcs
      fromUTF16 [] = []

    charsToCWchars = foldr utf16Char [] . map ord
     where
      utf16Char c wcs
        | c < 0x10000 = fromIntegral c : wcs
        | otherwise   = let c' = c - 0x10000 in
                        fromIntegral (c' `div` 0x400 + 0xd800) :
                        fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs

    #else /* !mingw32_HOST_OS */

    cWcharsToChars xs  = map castCWcharToChar xs
    charsToCWchars xs  = map castCharToCWchar xs

    -- These conversions only make sense if __STDC_ISO_10646__ is defined
    -- (meaning that wchar_t is ISO 10646, aka Unicode)

    castCWcharToChar :: CWchar -> Char
    castCWcharToChar ch = chr (fromIntegral ch )

    castCharToCWchar :: Char -> CWchar
    castCharToCWchar ch = fromIntegral (ord ch)

    #endif /* !mingw32_HOST_OS */