{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- 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,
  CStringLen,

  -- ** Using a locale-dependent encoding

  -- | These functions are different from their @CAString@ counterparts
  -- in that they will use an encoding determined by the current locale,
  -- rather than always assuming ASCII.

  -- 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,

  charIsRepresentable,

  -- ** 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,
  castCCharToChar,

  castCharToCUChar,
  castCUCharToChar,
  castCharToCSChar,
  castCSCharToChar,

  peekCAString,
  peekCAStringLen,
  newCAString,
  newCAStringLen,
  withCAString,
  withCAStringLen,

  -- * 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,
  CWStringLen,

  peekCWString,
  peekCWStringLen,
  newCWString,
  newCWStringLen,
  withCWString,
  withCWStringLen,

  ) where

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

import Data.Word

import GHC.Char
import GHC.List
import GHC.Real
import GHC.Num
import GHC.Base

import {-# SOURCE #-} GHC.IO.Encoding
import qualified GHC.Foreign as GHC

-----------------------------------------------------------------------------
-- 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 s = getForeignEncoding >>= flip GHC.peekCString s

-- | Marshal a C string with explicit length into a Haskell string.
--
peekCStringLen           :: CStringLen -> IO String
peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s

-- | 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 s = getForeignEncoding >>= flip GHC.newCString s

-- | 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 s = getForeignEncoding >>= flip GHC.newCStringLen s

-- | 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 s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f

-- | 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 s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f

-- -- | Determines whether a character can be accurately encoded in a 'CString'.
-- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent.
charIsRepresentable :: Char -> IO Bool
charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c

-- 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)

-- | Convert a C @unsigned char@, representing a Latin-1 character, to
-- the corresponding Haskell character.
castCUCharToChar :: CUChar -> Char
castCUCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))

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

-- | Convert a C @signed char@, representing a Latin-1 character, to the
-- corresponding Haskell character.
castCSCharToChar :: CSChar -> Char
castCSCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))

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

-- | Marshal a NUL terminated C string into a Haskell string.
--
peekCAString    :: CString -> IO String
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)

-- | Marshal a C string with explicit length into a Haskell string.
--
peekCAStringLen           :: CStringLen -> IO String
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)

-- | 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
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

-- | 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
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

-- | 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
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

-- | 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
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

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

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

-- allocate an array to hold the list and pair it with the number of elements
newArrayLen        :: Storable a => [a] -> IO (Ptr a, Int)
newArrayLen xs      = do
  a <- newArray xs
  return (a, length xs)

-----------------------------------------------------------------------------
-- 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  = newArrayLen (charsToCWchars str)

-- | 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 C wide string (i.e. wide
-- 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.
--
withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a
withCWStringLen str f    =
  withArrayLen (charsToCWchars str) $ \ len ptr -> f (ptr, len)

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

wNUL :: CWchar
wNUL = 0

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

#if defined(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 */


{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-unused-binds #-}
-- XXX -Wno-unused-binds stops us warning about unused constructors,
-- but really we should just remove them if we don't want them

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.C.Types
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Mapping of C types to corresponding Haskell types.
--
-----------------------------------------------------------------------------

module Foreign.C.Types
        ( -- * Representations of C types
          -- $ctypes

          -- ** Platform differences
          -- | This module contains platform specific information about types.
          --   __/As such the types presented on this page reflect the platform
          --   on which the documentation was generated and may not coincide with
          --   the types on your platform./__

          -- ** Integral types
          -- | These types are represented as @newtype@s of
          -- types in "Data.Int" and "Data.Word", and are instances of
          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
          -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable',
          -- 'Storable', 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral'
          -- and 'Bits'.
          CChar(..),    CSChar(..),   CUChar(..)
        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)
        , CLong(..),    CULong(..)
        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)
        , CLLong(..),   CULLong(..), CBool(..)
        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)

          -- ** Numeric types
          -- | These types are represented as @newtype@s of basic
          -- foreign types, and are instances of
          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
          -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable' and
          -- 'Storable'.
        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)

        -- extracted from CTime, because we don't want this comment in
        -- the Haskell language reports:

        -- | To convert 'CTime' to 'Data.Time.UTCTime', use the following:
        --
        -- > \t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime)
        --

          -- ** Floating types
          -- | These types are represented as @newtype@s of
          -- 'Prelude.Float' and 'Prelude.Double', and are instances of
          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
          -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable', 'Storable',
          -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',
          -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean
          -- that `CFloat`'s (respectively `CDouble`'s) instances of
          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and
          -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s
          -- (respectively `Prelude.Double`'s).
        , CFloat(..),   CDouble(..)
        -- XXX GHC doesn't support CLDouble yet
        -- , CLDouble(..)

          -- See Note [Exporting constructors of marshallable foreign types]
          -- in Foreign.Ptr for why the constructors for these newtypes are
          -- exported.

          -- ** Other types

          -- Instances of: Eq and Storable
        , CFile,        CFpos,     CJmpBuf
        ) where

import Foreign.Storable
import Data.Bits        ( Bits(..), FiniteBits(..) )
import Data.Int         ( Int8,  Int16,  Int32,  Int64  )
import Data.Word        ( Word8, Word16, Word32, Word64 )

import GHC.Base
import GHC.Float
import GHC.Enum
import GHC.Real
import GHC.Show
import GHC.Read
import GHC.Num

#include "HsBaseConfig.h"
#include "CTypes.h"

-- | Haskell type representing the C @char@ type.
INTEGRAL_TYPE(CChar,HTYPE_CHAR)
-- | Haskell type representing the C @signed char@ type.
INTEGRAL_TYPE(CSChar,HTYPE_SIGNED_CHAR)
-- | Haskell type representing the C @unsigned char@ type.
INTEGRAL_TYPE(CUChar,HTYPE_UNSIGNED_CHAR)

-- | Haskell type representing the C @short@ type.
INTEGRAL_TYPE(CShort,HTYPE_SHORT)
-- | Haskell type representing the C @unsigned short@ type.
INTEGRAL_TYPE(CUShort,HTYPE_UNSIGNED_SHORT)

-- | Haskell type representing the C @int@ type.
INTEGRAL_TYPE(CInt,HTYPE_INT)
-- | Haskell type representing the C @unsigned int@ type.
INTEGRAL_TYPE(CUInt,HTYPE_UNSIGNED_INT)

-- | Haskell type representing the C @long@ type.
INTEGRAL_TYPE(CLong,HTYPE_LONG)
-- | Haskell type representing the C @unsigned long@ type.
INTEGRAL_TYPE(CULong,HTYPE_UNSIGNED_LONG)

-- | Haskell type representing the C @long long@ type.
INTEGRAL_TYPE(CLLong,HTYPE_LONG_LONG)
-- | Haskell type representing the C @unsigned long long@ type.
INTEGRAL_TYPE(CULLong,HTYPE_UNSIGNED_LONG_LONG)

-- | Haskell type representing the C @bool@ type.
--
-- @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CBool,bool,HTYPE_BOOL)

{-# RULES
"fromIntegral/a->CChar"   fromIntegral = \x -> CChar   (fromIntegral x)
"fromIntegral/a->CSChar"  fromIntegral = \x -> CSChar  (fromIntegral x)
"fromIntegral/a->CUChar"  fromIntegral = \x -> CUChar  (fromIntegral x)
"fromIntegral/a->CShort"  fromIntegral = \x -> CShort  (fromIntegral x)
"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x)
"fromIntegral/a->CInt"    fromIntegral = \x -> CInt    (fromIntegral x)
"fromIntegral/a->CUInt"   fromIntegral = \x -> CUInt   (fromIntegral x)
"fromIntegral/a->CLong"   fromIntegral = \x -> CLong   (fromIntegral x)
"fromIntegral/a->CULong"  fromIntegral = \x -> CULong  (fromIntegral x)
"fromIntegral/a->CLLong"  fromIntegral = \x -> CLLong  (fromIntegral x)
"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x)

"fromIntegral/CChar->a"   fromIntegral = \(CChar   x) -> fromIntegral x
"fromIntegral/CSChar->a"  fromIntegral = \(CSChar  x) -> fromIntegral x
"fromIntegral/CUChar->a"  fromIntegral = \(CUChar  x) -> fromIntegral x
"fromIntegral/CShort->a"  fromIntegral = \(CShort  x) -> fromIntegral x
"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x
"fromIntegral/CInt->a"    fromIntegral = \(CInt    x) -> fromIntegral x
"fromIntegral/CUInt->a"   fromIntegral = \(CUInt   x) -> fromIntegral x
"fromIntegral/CLong->a"   fromIntegral = \(CLong   x) -> fromIntegral x
"fromIntegral/CULong->a"  fromIntegral = \(CULong  x) -> fromIntegral x
"fromIntegral/CLLong->a"  fromIntegral = \(CLLong  x) -> fromIntegral x
"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x
"fromIntegral/CBool->a"   fromIntegral = \(CBool   x) -> fromIntegral x
 #-}

-- | Haskell type representing the C @float@ type.
FLOATING_TYPE(CFloat,HTYPE_FLOAT)
-- | Haskell type representing the C @double@ type.
FLOATING_TYPE(CDouble,HTYPE_DOUBLE)
-- XXX GHC doesn't support CLDouble yet

{-# RULES
"realToFrac/a->CFloat"    realToFrac = \x -> CFloat   (realToFrac x)
"realToFrac/a->CDouble"   realToFrac = \x -> CDouble  (realToFrac x)

"realToFrac/CFloat->a"    realToFrac = \(CFloat   x) -> realToFrac x
"realToFrac/CDouble->a"   realToFrac = \(CDouble  x) -> realToFrac x
 #-}

-- GHC doesn't support CLDouble yet
-- "realToFrac/a->CLDouble"  realToFrac = \x -> CLDouble (realToFrac x)
-- "realToFrac/CLDouble->a"  realToFrac = \(CLDouble x) -> realToFrac x

-- | Haskell type representing the C @ptrdiff_t@ type.
INTEGRAL_TYPE(CPtrdiff,HTYPE_PTRDIFF_T)
-- | Haskell type representing the C @size_t@ type.
INTEGRAL_TYPE(CSize,HTYPE_SIZE_T)
-- | Haskell type representing the C @wchar_t@ type.
INTEGRAL_TYPE(CWchar,HTYPE_WCHAR_T)
-- | Haskell type representing the C @sig_atomic_t@ type.
INTEGRAL_TYPE(CSigAtomic,HTYPE_SIG_ATOMIC_T)

{-# RULES
"fromIntegral/a->CPtrdiff"   fromIntegral = \x -> CPtrdiff   (fromIntegral x)
"fromIntegral/a->CSize"      fromIntegral = \x -> CSize      (fromIntegral x)
"fromIntegral/a->CWchar"     fromIntegral = \x -> CWchar     (fromIntegral x)
"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x)

"fromIntegral/CPtrdiff->a"   fromIntegral = \(CPtrdiff   x) -> fromIntegral x
"fromIntegral/CSize->a"      fromIntegral = \(CSize      x) -> fromIntegral x
"fromIntegral/CWchar->a"     fromIntegral = \(CWchar     x) -> fromIntegral x
"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x
 #-}

-- | Haskell type representing the C @clock_t@ type.
ARITHMETIC_TYPE(CClock,HTYPE_CLOCK_T)
-- | Haskell type representing the C @time_t@ type.
ARITHMETIC_TYPE(CTime,HTYPE_TIME_T)
-- | Haskell type representing the C @useconds_t@ type.
--
-- @since 4.4.0.0

ARITHMETIC_TYPE(CUSeconds,HTYPE_USECONDS_T)
-- | Haskell type representing the C @suseconds_t@ type.
--
-- @since 4.4.0.0
ARITHMETIC_TYPE(CSUSeconds,HTYPE_SUSECONDS_T)

-- FIXME: Implement and provide instances for Eq and Storable
-- | Haskell type representing the C @FILE@ type.
data CFile = CFile
-- | Haskell type representing the C @fpos_t@ type.
data CFpos = CFpos
-- | Haskell type representing the C @jmp_buf@ type.
data CJmpBuf = CJmpBuf

INTEGRAL_TYPE(CIntPtr,HTYPE_INTPTR_T)
INTEGRAL_TYPE(CUIntPtr,HTYPE_UINTPTR_T)
INTEGRAL_TYPE(CIntMax,HTYPE_INTMAX_T)
INTEGRAL_TYPE(CUIntMax,HTYPE_UINTMAX_T)

{-# RULES
"fromIntegral/a->CIntPtr"  fromIntegral = \x -> CIntPtr  (fromIntegral x)
"fromIntegral/a->CUIntPtr" fromIntegral = \x -> CUIntPtr (fromIntegral x)
"fromIntegral/a->CIntMax"  fromIntegral = \x -> CIntMax  (fromIntegral x)
"fromIntegral/a->CUIntMax" fromIntegral = \x -> CUIntMax (fromIntegral x)
 #-}

-- C99 types which are still missing include:
-- wint_t, wctrans_t, wctype_t

{- $ctypes

These types are needed to accurately represent C function prototypes,
in order to access C library interfaces in Haskell.  The Haskell system
is not required to represent those types exactly as C does, but the
following guarantees are provided concerning a Haskell type @CT@
representing a C type @t@:

* If a C function prototype has @t@ as an argument or result type, the
  use of @CT@ in the corresponding position in a foreign declaration
  permits the Haskell program to access the full range of values encoded
  by the C type; and conversely, any Haskell value for @CT@ has a valid
  representation in C.

* @'sizeOf' ('Prelude.undefined' :: CT)@ will yield the same value as
  @sizeof (t)@ in C.

* @'alignment' ('Prelude.undefined' :: CT)@ matches the alignment
  constraint enforced by the C implementation for @t@.

* The members 'peek' and 'poke' of the 'Storable' class map all values
  of @CT@ to the corresponding value of @t@ and vice versa.

* When an instance of 'Prelude.Bounded' is defined for @CT@, the values
  of 'Prelude.minBound' and 'Prelude.maxBound' coincide with @t_MIN@
  and @t_MAX@ in C.

* When an instance of 'Prelude.Eq' or 'Prelude.Ord' is defined for @CT@,
  the predicates defined by the type class implement the same relation
  as the corresponding predicate in C on @t@.

* When an instance of 'Prelude.Num', 'Prelude.Read', 'Prelude.Integral',
  'Prelude.Fractional', 'Prelude.Floating', 'Prelude.RealFrac', or
  'Prelude.RealFloat' is defined for @CT@, the arithmetic operations
  defined by the type class implement the same function as the
  corresponding arithmetic operations (if available) in C on @t@.

* When an instance of 'Bits' is defined for @CT@, the bitwise operation
  defined by the type class implement the same function as the
  corresponding bitwise operation in C on @t@.

-}


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.ForeignPtr.Imp
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The 'ForeignPtr' type and operations.  This module is part of the
-- Foreign Function Interface (FFI) and will usually be imported via
-- the "Foreign" module.
--
-----------------------------------------------------------------------------

module Foreign.ForeignPtr.Imp
        (
        -- * Finalised data pointers
          ForeignPtr
        , FinalizerPtr
        , FinalizerEnvPtr

        -- ** Basic operations
        , newForeignPtr
        , newForeignPtr_
        , addForeignPtrFinalizer
        , newForeignPtrEnv
        , addForeignPtrFinalizerEnv
        , withForeignPtr
        , finalizeForeignPtr

        -- ** Low-level operations
        , unsafeForeignPtrToPtr
        , touchForeignPtr
        , castForeignPtr
        , plusForeignPtr

        -- ** Allocating managed memory
        , mallocForeignPtr
        , mallocForeignPtrBytes
        , mallocForeignPtrArray
        , mallocForeignPtrArray0
        )
        where

import Foreign.Ptr
import Foreign.Storable ( Storable(sizeOf) )

import GHC.Base
import GHC.Num
import GHC.ForeignPtr

newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
-- ^Turns a plain memory reference into a foreign pointer, and
-- associates a finalizer with the reference.  The finalizer will be
-- executed after the last reference to the foreign object is dropped.
-- There is no guarantee of promptness, however the finalizer will be
-- executed before the program exits.
newForeignPtr finalizer p
  = do fObj <- newForeignPtr_ p
       addForeignPtrFinalizer finalizer fObj
       return fObj

withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
-- ^This is a way to look at the pointer living inside a
-- foreign object.  This function takes a function which is
-- applied to that pointer. The resulting 'IO' action is then
-- executed. The foreign object is kept alive at least during
-- the whole action, even if it is not used directly
-- inside. Note that it is not safe to return the pointer from
-- the action and use it after the action completes. All uses
-- of the pointer should be inside the
-- 'withForeignPtr' bracket.  The reason for
-- this unsafeness is the same as for
-- 'unsafeForeignPtrToPtr' below: the finalizer
-- may run earlier than expected, because the compiler can only
-- track usage of the 'ForeignPtr' object, not
-- a 'Ptr' object made from it.
--
-- This function is normally used for marshalling data to
-- or from the object pointed to by the
-- 'ForeignPtr', using the operations from the
-- 'Storable' class.
withForeignPtr fo io
  = do r <- io (unsafeForeignPtrToPtr fo)
       touchForeignPtr fo
       return r

-- | This variant of 'newForeignPtr' adds a finalizer that expects an
-- environment in addition to the finalized pointer.  The environment
-- that will be passed to the finalizer is fixed by the second argument to
-- 'newForeignPtrEnv'.
newForeignPtrEnv ::
    FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)
newForeignPtrEnv finalizer env p
  = do fObj <- newForeignPtr_ p
       addForeignPtrFinalizerEnv finalizer env fObj
       return fObj

-- | This function is similar to 'Foreign.Marshal.Array.mallocArray',
-- but yields a memory area that has a finalizer attached that releases
-- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that
-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.
mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray  = doMalloc undefined
  where
    doMalloc            :: Storable b => b -> Int -> IO (ForeignPtr b)
    doMalloc dummy size  = mallocForeignPtrBytes (size * sizeOf dummy)

-- | This function is similar to 'Foreign.Marshal.Array.mallocArray0',
-- but yields a memory area that has a finalizer attached that releases
-- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that
-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.
mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.ForeignPtr.Safe
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The 'ForeignPtr' type and operations.  This module is part of the
-- Foreign Function Interface (FFI) and will usually be imported via
-- the "Foreign" module.
--
-- Safe API Only.
--
-----------------------------------------------------------------------------

module Foreign.ForeignPtr.Safe {-# DEPRECATED "Safe is now the default, please use Foreign.ForeignPtr instead" #-} (
        -- * Finalised data pointers
          ForeignPtr
        , FinalizerPtr
        , FinalizerEnvPtr

        -- ** Basic operations
        , newForeignPtr
        , newForeignPtr_
        , addForeignPtrFinalizer
        , newForeignPtrEnv
        , addForeignPtrFinalizerEnv
        , withForeignPtr
        , finalizeForeignPtr

        -- ** Low-level operations
        , touchForeignPtr
        , castForeignPtr

        -- ** Allocating managed memory
        , mallocForeignPtr
        , mallocForeignPtrBytes
        , mallocForeignPtrArray
        , mallocForeignPtrArray0
    ) where

import Foreign.ForeignPtr.Imp


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.ForeignPtr.Unsafe
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The 'ForeignPtr' type and operations.  This module is part of the
-- Foreign Function Interface (FFI) and will usually be imported via
-- the "Foreign" module.
--
-- Unsafe API Only.
--
-----------------------------------------------------------------------------

module Foreign.ForeignPtr.Unsafe (
        -- ** Unsafe low-level operations
        unsafeForeignPtrToPtr,
    ) where

import Foreign.ForeignPtr.Imp


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples,
             ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Alloc
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- The module "Foreign.Marshal.Alloc" provides operations to allocate and
-- deallocate blocks of raw memory (i.e., unstructured chunks of memory
-- outside of the area maintained by the Haskell storage manager).  These
-- memory blocks are commonly used to pass compound data structures to
-- foreign functions or to provide space in which compound result values
-- are obtained from foreign functions.
--
-- If any of the allocation functions fails, an exception is thrown.
-- In some cases, memory exhaustion may mean the process is terminated.
-- If 'free' or 'reallocBytes' is applied to a memory area
-- that has been allocated with 'alloca' or 'allocaBytes', the
-- behaviour is undefined.  Any further access to memory areas allocated with
-- 'alloca' or 'allocaBytes', after the computation that was passed to
-- the allocation function has terminated, leads to undefined behaviour.  Any
-- further access to the memory area referenced by a pointer passed to
-- 'realloc', 'reallocBytes', or 'free' entails undefined
-- behaviour.
--
-- All storage allocated by functions that allocate based on a /size in bytes/
-- must be sufficiently aligned for any of the basic foreign types
-- that fits into the newly allocated storage. All storage allocated by
-- functions that allocate based on a specific type must be sufficiently
-- aligned for that type. Array allocation routines need to obey the same
-- alignment constraints for each array element.
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Alloc (
  -- * Memory allocation
  -- ** Local allocation
  alloca,
  allocaBytes,
  allocaBytesAligned,

  -- ** Dynamic allocation
  malloc,
  mallocBytes,

  calloc,
  callocBytes,

  realloc,
  reallocBytes,

  free,
  finalizerFree
) where

import Data.Maybe
import Foreign.C.Types          ( CSize(..) )
import Foreign.Storable         ( Storable(sizeOf,alignment) )
import Foreign.ForeignPtr       ( FinalizerPtr )
import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Base

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

-- |Allocate a block of memory that is sufficient to hold values of type
-- @a@.  The size of the area allocated is determined by the 'sizeOf'
-- method from the instance of 'Storable' for the appropriate type.
--
-- The memory may be deallocated using 'free' or 'finalizerFree' when
-- no longer required.
--
{-# INLINE malloc #-}
malloc :: forall a . Storable a => IO (Ptr a)
malloc  = mallocBytes (sizeOf (undefined :: a))

-- |Like 'malloc' but memory is filled with bytes of value zero.
--
{-# INLINE calloc #-}
calloc :: forall a . Storable a => IO (Ptr a)
calloc = callocBytes (sizeOf (undefined :: a))

-- |Allocate a block of memory of the given number of bytes.
-- The block of memory is sufficiently aligned for any of the basic
-- foreign types that fits into a memory block of the allocated size.
--
-- The memory may be deallocated using 'free' or 'finalizerFree' when
-- no longer required.
--
mallocBytes      :: Int -> IO (Ptr a)
mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))

-- |Llike 'mallocBytes' but memory is filled with bytes of value zero.
--
callocBytes :: Int -> IO (Ptr a)
callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size)

-- |@'alloca' f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory sufficient to
-- hold values of type @a@.
--
-- The memory is freed when @f@ terminates (either normally or via an
-- exception), so the pointer passed to @f@ must /not/ be used after this.
--
{-# INLINE alloca #-}
alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
alloca  =
  allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a))

-- Note [NOINLINE for touch#]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously
-- fragile in the presence of simplification (see #14346). In particular, the
-- simplifier may drop the continuation containing the touch# if it can prove
-- that the action passed to allocaBytes will not return. The hack introduced to
-- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the
-- simplifier can't see the divergence.
--
-- These can be removed once #14375 is fixed, which suggests that we instead do
-- away with touch# in favor of a primitive that will capture the scoping left
-- implicit in the case of touch#.

-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory of @n@ bytes.
-- The block of memory is sufficiently aligned for any of the basic
-- foreign types that fits into a memory block of the allocated size.
--
-- The memory is freed when @f@ terminates (either normally or via an
-- exception), so the pointer passed to @f@ must /not/ be used after this.
--
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
allocaBytes (I# size) action = IO $ \ s0 ->
     case newPinnedByteArray# size s0      of { (# s1, mbarr# #) ->
     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
     let addr = Ptr (byteArrayContents# barr#) in
     case action addr     of { IO action' ->
     case action' s2      of { (# s3, r #) ->
     case touch# barr# s3 of { s4 ->
     (# s4, r #)
  }}}}}
-- See Note [NOINLINE for touch#]
{-# NOINLINE allocaBytes #-}

allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
     case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) ->
     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
     let addr = Ptr (byteArrayContents# barr#) in
     case action addr     of { IO action' ->
     case action' s2      of { (# s3, r #) ->
     case touch# barr# s3 of { s4 ->
     (# s4, r #)
  }}}}}
-- See Note [NOINLINE for touch#]
{-# NOINLINE allocaBytesAligned #-}

-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the size needed to store values of type @b@.  The returned pointer
-- may refer to an entirely different memory area, but will be suitably
-- aligned to hold values of type @b@.  The contents of the referenced
-- memory area will be the same as of the original pointer up to the
-- minimum of the original size and the size of values of type @b@.
--
-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like
-- 'malloc'.
--
realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b)
realloc ptr = failWhenNULL "realloc" (_realloc ptr size)
  where
    size = fromIntegral (sizeOf (undefined :: b))

-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the given size.  The returned pointer may refer to an entirely
-- different memory area, but will be sufficiently aligned for any of the
-- basic foreign types that fits into a memory block of the given size.
-- The contents of the referenced memory area will be the same as of
-- the original pointer up to the minimum of the original size and the
-- given size.
--
-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'
-- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'
-- behaves like 'free'.
--
reallocBytes          :: Ptr a -> Int -> IO (Ptr a)
reallocBytes ptr 0     = do free ptr; return nullPtr
reallocBytes ptr size  =
  failWhenNULL "realloc" (_realloc ptr (fromIntegral size))

-- |Free a block of memory that was allocated with 'malloc',
-- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'
-- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or
-- "Foreign.C.String".
--
free :: Ptr a -> IO ()
free  = _free

-- auxiliary routines
-- -------------------

-- asserts that the pointer returned from the action in the second argument is
-- non-null
--
failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
failWhenNULL name f = do
   addr <- f
   if addr == nullPtr
      then ioError (IOError Nothing ResourceExhausted name
                                        "out of memory" Nothing Nothing)
      else return addr

-- basic C routines needed for memory allocation
--
foreign import ccall unsafe "stdlib.h malloc"  _malloc  ::          CSize -> IO (Ptr a)
foreign import ccall unsafe "stdlib.h calloc"  _calloc  :: CSize -> CSize -> IO (Ptr a)
foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)
foreign import ccall unsafe "stdlib.h free"    _free    :: Ptr a -> IO ()

-- | A pointer to a foreign function equivalent to 'free', which may be
-- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage
-- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.
foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Array
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Marshalling support: routines allocating, storing, and retrieving Haskell
-- lists that are represented as arrays in the foreign language
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Array (
  -- * Marshalling arrays

  -- ** Allocation
  --
  mallocArray,
  mallocArray0,

  allocaArray,
  allocaArray0,

  reallocArray,
  reallocArray0,

  callocArray,
  callocArray0,

  -- ** Marshalling
  --
  peekArray,
  peekArray0,

  pokeArray,
  pokeArray0,

  -- ** Combined allocation and marshalling
  --
  newArray,
  newArray0,

  withArray,
  withArray0,

  withArrayLen,
  withArrayLen0,

  -- ** Copying

  -- | (argument order: destination, source)
  copyArray,
  moveArray,

  -- ** Finding the length
  --
  lengthArray0,

  -- ** Indexing
  --
  advancePtr,
) where

import Foreign.Ptr      (Ptr, plusPtr)
import Foreign.Storable (Storable(alignment,sizeOf,peekElemOff,pokeElemOff))
import Foreign.Marshal.Alloc (mallocBytes, callocBytes, allocaBytesAligned, reallocBytes)
import Foreign.Marshal.Utils (copyBytes, moveBytes)

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

-- allocation
-- ----------

-- |Allocate storage for the given number of elements of a storable type
-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).
--
mallocArray :: forall a . Storable a => Int -> IO (Ptr a)
mallocArray  size = mallocBytes (size * sizeOf (undefined :: a))

-- |Like 'mallocArray', but add an extra position to hold a special
-- termination element.
--
mallocArray0      :: Storable a => Int -> IO (Ptr a)
mallocArray0 size  = mallocArray (size + 1)

-- |Like 'mallocArray', but allocated memory is filled with bytes of value zero.
--
callocArray :: forall a . Storable a => Int -> IO (Ptr a)
callocArray size = callocBytes (size * sizeOf (undefined :: a))

-- |Like 'callocArray0', but allocated memory is filled with bytes of value
-- zero.
--
callocArray0 :: Storable a => Int -> IO (Ptr a)
callocArray0 size  = callocArray (size + 1)

-- |Temporarily allocate space for the given number of elements
-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).
--
allocaArray :: forall a b . Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray size = allocaBytesAligned (size * sizeOf (undefined :: a))
                                      (alignment (undefined :: a))

-- |Like 'allocaArray', but add an extra position to hold a special
-- termination element.
--
allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray0 size  = allocaArray (size + 1)
{-# INLINE allocaArray0 #-}
  -- needed to get allocaArray to inline into withCString, for unknown
  -- reasons --SDM 23/4/2010, see #4004 for benchmark

-- |Adjust the size of an array
--
reallocArray :: forall a . Storable a => Ptr a -> Int -> IO (Ptr a)
reallocArray ptr size = reallocBytes ptr (size * sizeOf (undefined :: a))

-- |Adjust the size of an array including an extra position for the end marker.
--
reallocArray0          :: Storable a => Ptr a -> Int -> IO (Ptr a)
reallocArray0 ptr size  = reallocArray ptr (size + 1)

-- marshalling
-- -----------

-- |Convert an array of given length into a Haskell list.  The implementation
-- is tail-recursive and so uses constant stack space.
--
peekArray          :: Storable a => Int -> Ptr a -> IO [a]
peekArray size ptr | size <= 0 = return []
                 | otherwise = f (size-1) []
  where
    f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)
    f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)

-- |Convert an array terminated by the given end marker into a Haskell list
--
peekArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO [a]
peekArray0 marker ptr  = do
  size <- lengthArray0 marker ptr
  peekArray size ptr

-- |Write the list elements consecutive into memory
--
pokeArray :: Storable a => Ptr a -> [a] -> IO ()
pokeArray ptr vals0 = go vals0 0#
  where go [] _          = return ()
        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)

-- |Write the list elements consecutive into memory and terminate them with the
-- given marker element
--
pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()
pokeArray0 marker ptr vals0 = go vals0 0#
  where go [] n#         = pokeElemOff ptr (I# n#) marker
        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)

-- combined allocation and marshalling
-- -----------------------------------

-- |Write a list of storable elements into a newly allocated, consecutive
-- sequence of storable values
-- (like 'Foreign.Marshal.Utils.new', but for multiple elements).
--
newArray      :: Storable a => [a] -> IO (Ptr a)
newArray vals  = do
  ptr <- mallocArray (length vals)
  pokeArray ptr vals
  return ptr

-- |Write a list of storable elements into a newly allocated, consecutive
-- sequence of storable values, where the end is fixed by the given end marker
--
newArray0             :: Storable a => a -> [a] -> IO (Ptr a)
newArray0 marker vals  = do
  ptr <- mallocArray0 (length vals)
  pokeArray0 marker ptr vals
  return ptr

-- |Temporarily store a list of storable values in memory
-- (like 'Foreign.Marshal.Utils.with', but for multiple elements).
--
withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray vals = withArrayLen vals . const

-- |Like 'withArray', but the action gets the number of values
-- as an additional parameter
--
withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen vals f  =
  allocaArray len $ \ptr -> do
      pokeArray ptr vals
      f len ptr
  where
    len = length vals

-- |Like 'withArray', but a terminator indicates where the array ends
--
withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 marker vals = withArrayLen0 marker vals . const

-- |Like 'withArrayLen', but a terminator indicates where the array ends
--
withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen0 marker vals f  =
  allocaArray0 len $ \ptr -> do
      pokeArray0 marker ptr vals
      res <- f len ptr
      return res
  where
    len = length vals

-- copying (argument order: destination, source)
-- -------

-- |Copy the given number of elements from the second array (source) into the
-- first array (destination); the copied areas may /not/ overlap
--
copyArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray dest src size = copyBytes dest src (size * sizeOf (undefined :: a))

-- |Copy the given number of elements from the second array (source) into the
-- first array (destination); the copied areas /may/ overlap
--
moveArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray  dest src size = moveBytes dest src (size * sizeOf (undefined :: a))

-- finding the length
-- ------------------

-- |Return the number of elements in an array, excluding the terminator
--
lengthArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO Int
lengthArray0 marker ptr  = loop 0
  where
    loop i = do
        val <- peekElemOff ptr i
        if val == marker then return i else loop (i+1)

-- indexing
-- --------

-- |Advance a pointer into an array by the given number of elements
--
advancePtr :: forall a . Storable a => Ptr a -> Int -> Ptr a
advancePtr ptr i = ptr `plusPtr` (i * sizeOf (undefined :: a))


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Error
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Routines for testing return values and raising a 'userError' exception
-- in case of values indicating an error state.
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Error (
  throwIf,
  throwIf_,
  throwIfNeg,
  throwIfNeg_,
  throwIfNull,

  -- Discard return value
  --
  void
) where

import Foreign.Ptr

import GHC.Base
import GHC.Num
import GHC.IO.Exception

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

-- |Execute an 'IO' action, throwing a 'userError' if the predicate yields
-- 'True' when applied to the result returned by the 'IO' action.
-- If no exception is raised, return the result of the computation.
--
throwIf :: (a -> Bool)  -- ^ error condition on the result of the 'IO' action
        -> (a -> String) -- ^ computes an error message from erroneous results
                        -- of the 'IO' action
        -> IO a         -- ^ the 'IO' action to be executed
        -> IO a
throwIf pred msgfct act  =
  do
    res <- act
    (if pred res then ioError . userError . msgfct else return) res

-- |Like 'throwIf', but discarding the result
--
throwIf_                 :: (a -> Bool) -> (a -> String) -> IO a -> IO ()
throwIf_ pred msgfct act  = void $ throwIf pred msgfct act

-- |Guards against negative result values
--
throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a
throwIfNeg  = throwIf (< 0)

-- |Like 'throwIfNeg', but discarding the result
--
throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()
throwIfNeg_  = throwIf_ (< 0)

-- |Guards against null pointers
--
throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwIfNull  = throwIf (== nullPtr) . const

-- |Discard the return value of an 'IO' action
--
void     :: IO a -> IO ()
void act  = act >> return ()
{-# DEPRECATED void "use 'Control.Monad.void' instead" #-} -- deprecated in 7.6


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

--------------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Pool
-- Copyright   :  (c) Sven Panne 2002-2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  sven.panne@aedion.de
-- Stability   :  provisional
-- Portability :  portable
--
-- This module contains support for pooled memory management. Under this scheme,
-- (re-)allocations belong to a given pool, and everything in a pool is
-- deallocated when the pool itself is deallocated. This is useful when
-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation
-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'
-- and 'free' are too awkward.
--
--------------------------------------------------------------------------------

module Foreign.Marshal.Pool (
   -- * Pool management
   Pool,
   newPool,
   freePool,
   withPool,

   -- * (Re-)Allocation within a pool
   pooledMalloc,
   pooledMallocBytes,

   pooledRealloc,
   pooledReallocBytes,

   pooledMallocArray,
   pooledMallocArray0,

   pooledReallocArray,
   pooledReallocArray0,

   -- * Combined allocation and marshalling
   pooledNew,
   pooledNewArray,
   pooledNewArray0
) where

import GHC.Base              ( Int, Monad(..), (.), liftM, not )
import GHC.Err               ( undefined )
import GHC.Exception         ( throw )
import GHC.IO                ( IO, mask, catchAny )
import GHC.IORef             ( IORef, newIORef, readIORef, writeIORef )
import GHC.List              ( elem, length )
import GHC.Num               ( Num(..) )

import Data.OldList          ( delete )
import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
import Foreign.Marshal.Array ( pokeArray, pokeArray0 )
import Foreign.Marshal.Error ( throwIf )
import Foreign.Ptr           ( Ptr, castPtr )
import Foreign.Storable      ( Storable(sizeOf, poke) )

--------------------------------------------------------------------------------

-- To avoid non-H2010 stuff like existentially quantified data constructors, we
-- simply use pointers to () below. Not very nice, but...

-- | A memory pool.

newtype Pool = Pool (IORef [Ptr ()])

-- | Allocate a fresh memory pool.

newPool :: IO Pool
newPool = liftM Pool (newIORef [])

-- | Deallocate a memory pool and everything which has been allocated in the
-- pool itself.

freePool :: Pool -> IO ()
freePool (Pool pool) = readIORef pool >>= freeAll
   where freeAll []     = return ()
         freeAll (p:ps) = free p >> freeAll ps

-- | Execute an action with a fresh memory pool, which gets automatically
-- deallocated (including its contents) after the action has finished.

withPool :: (Pool -> IO b) -> IO b
withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!
   mask (\restore -> do
      pool <- newPool
      val <- catchAny
                (restore (act pool))
                (\e -> do freePool pool; throw e)
      freePool pool
      return val)

--------------------------------------------------------------------------------

-- | Allocate space for storable type in the given pool. The size of the area
-- allocated is determined by the 'sizeOf' method from the instance of
-- 'Storable' for the appropriate type.

pooledMalloc :: forall a . Storable a => Pool -> IO (Ptr a)
pooledMalloc pool = pooledMallocBytes pool (sizeOf (undefined :: a))

-- | Allocate the given number of bytes of storage in the pool.

pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes (Pool pool) size = do
   ptr <- mallocBytes size
   ptrs <- readIORef pool
   writeIORef pool (ptr:ptrs)
   return (castPtr ptr)

-- | Adjust the storage area for an element in the pool to the given size of
-- the required type.

pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc pool ptr = pooledReallocBytes pool ptr (sizeOf (undefined :: a))

-- | Adjust the storage area for an element in the pool to the given size.

pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes (Pool pool) ptr size = do
   let cPtr = castPtr ptr
   _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
   newPtr <- reallocBytes cPtr size
   ptrs <- readIORef pool
   writeIORef pool (newPtr : delete cPtr ptrs)
   return (castPtr newPtr)

-- | Allocate storage for the given number of elements of a storable type in the
-- pool.

pooledMallocArray :: forall a . Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray pool size =
    pooledMallocBytes pool (size * sizeOf (undefined :: a))

-- | Allocate storage for the given number of elements of a storable type in the
-- pool, but leave room for an extra element to signal the end of the array.

pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0 pool size =
   pooledMallocArray pool (size + 1)

-- | Adjust the size of an array in the given pool.

pooledReallocArray :: forall a . Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray pool ptr size =
    pooledReallocBytes pool ptr (size * sizeOf (undefined :: a))

-- | Adjust the size of an array with an end marker in the given pool.

pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0 pool ptr size =
   pooledReallocArray pool ptr (size + 1)

--------------------------------------------------------------------------------

-- | Allocate storage for a value in the given pool and marshal the value into
-- this storage.

pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
pooledNew pool val = do
   ptr <- pooledMalloc pool
   poke ptr val
   return ptr

-- | Allocate consecutive storage for a list of values in the given pool and
-- marshal these values into it.

pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray pool vals = do
   ptr <- pooledMallocArray pool (length vals)
   pokeArray ptr vals
   return ptr

-- | Allocate consecutive storage for a list of values in the given pool and
-- marshal these values into it, terminating the end with the given marker.

pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 pool marker vals = do
   ptr <- pooledMallocArray0 pool (length vals)
   pokeArray0 marker ptr vals
   return ptr


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Safe
-- Copyright   :  (c) The FFI task force 2003
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Marshalling support
--
-- Safe API Only.
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Safe {-# DEPRECATED "Safe is now the default, please use Foreign.Marshal instead" #-}
        (
         -- | The module "Foreign.Marshal.Safe" re-exports the other modules in the
         -- @Foreign.Marshal@ hierarchy:
          module Foreign.Marshal.Alloc
        , module Foreign.Marshal.Array
        , module Foreign.Marshal.Error
        , module Foreign.Marshal.Pool
        , module Foreign.Marshal.Utils
        ) where

import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Error
import Foreign.Marshal.Pool
import Foreign.Marshal.Utils


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Unsafe
-- Copyright   :  (c) The FFI task force 2003
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Marshalling support. Unsafe API.
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Unsafe (
        -- * Unsafe functions
        unsafeLocalState
    ) where

import GHC.IO

{- |
Sometimes an external entity is a pure function, except that it passes
arguments and/or results via pointers.  The function
@unsafeLocalState@ permits the packaging of such entities as pure
functions.

The only IO operations allowed in the IO action passed to
@unsafeLocalState@ are (a) local allocation (@alloca@, @allocaBytes@
and derived operations such as @withArray@ and @withCString@), and (b)
pointer operations (@Foreign.Storable@ and @Foreign.Ptr@) on the
pointers to local storage, and (c) foreign functions whose only
observable effect is to read and/or write the locally allocated
memory.  Passing an IO operation that does not obey these rules
results in undefined behaviour.

It is expected that this operation will be
replaced in a future revision of Haskell.
-}
unsafeLocalState :: IO a -> a
unsafeLocalState = unsafeDupablePerformIO


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Utils
-- 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 marshaling
--
-----------------------------------------------------------------------------

module Foreign.Marshal.Utils (
  -- * General marshalling utilities

  -- ** Combined allocation and marshalling
  --
  with,
  new,

  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')
  --
  fromBool,
  toBool,

  -- ** Marshalling of Maybe values
  --
  maybeNew,
  maybeWith,
  maybePeek,

  -- ** Marshalling lists of storable objects
  --
  withMany,

  -- ** Haskellish interface to memcpy and memmove
  -- | (argument order: destination, source)
  --
  copyBytes,
  moveBytes,

  -- ** Filling up memory area with required values
  --
  fillBytes,
) where

import Data.Maybe
import Foreign.Ptr              ( Ptr, nullPtr )
import Foreign.Storable         ( Storable(poke) )
import Foreign.C.Types          ( CSize(..), CInt(..) )
import Foreign.Marshal.Alloc    ( malloc, alloca )
import Data.Word                ( Word8 )

import GHC.Real                 ( fromIntegral )
import GHC.Num
import GHC.Base

-- combined allocation and marshalling
-- -----------------------------------

-- |Allocate a block of memory and marshal a value into it
-- (the combination of 'malloc' and 'poke').
-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'
-- method from the instance of 'Storable' for the appropriate type.
--
-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or
-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.
--
new     :: Storable a => a -> IO (Ptr a)
new val  =
  do
    ptr <- malloc
    poke ptr val
    return ptr

-- |@'with' val f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory into which
-- @val@ has been marshalled (the combination of 'alloca' and 'poke').
--
-- The memory is freed when @f@ terminates (either normally or via an
-- exception), so the pointer passed to @f@ must /not/ be used after this.
--
with       :: Storable a => a -> (Ptr a -> IO b) -> IO b
with val f  =
  alloca $ \ptr -> do
    poke ptr val
    res <- f ptr
    return res

-- marshalling of Boolean values (non-zero corresponds to 'True')
-- -----------------------------

-- |Convert a Haskell 'Bool' to its numeric representation
--
fromBool       :: Num a => Bool -> a
fromBool False  = 0
fromBool True   = 1

-- |Convert a Boolean in numeric representation to a Haskell value
--
toBool :: (Eq a, Num a) => a -> Bool
toBool  = (/= 0)

-- marshalling of Maybe values
-- ---------------------------

-- |Allocate storage and marshal a storable value wrapped into a 'Maybe'
--
-- * the 'nullPtr' is used to represent 'Nothing'
--
maybeNew :: (      a -> IO (Ptr b))
         -> (Maybe a -> IO (Ptr b))
maybeNew  = maybe (return nullPtr)

-- |Converts a @withXXX@ combinator into one marshalling a value wrapped
-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.
--
maybeWith :: (      a -> (Ptr b -> IO c) -> IO c)
          -> (Maybe a -> (Ptr b -> IO c) -> IO c)
maybeWith  = maybe ($ nullPtr)

-- |Convert a peek combinator into a one returning 'Nothing' if applied to a
-- 'nullPtr'
--
maybePeek                           :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek peek ptr | ptr == nullPtr  = return Nothing
                   | otherwise       = do a <- peek ptr; return (Just a)

-- marshalling lists of storable objects
-- -------------------------------------

-- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of
-- marshalled objects
--
withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object
         -> [a]                       -- storable objects
         -> ([b] -> res)              -- action on list of marshalled obj.s
         -> res
withMany _       []     f = f []
withMany withFoo (x:xs) f = withFoo x $ \x' ->
                              withMany withFoo xs (\xs' -> f (x':xs'))

-- Haskellish interface to memcpy and memmove
-- ------------------------------------------

-- |Copies the given number of bytes from the second area (source) into the
-- first (destination); the copied areas may /not/ overlap
--
copyBytes               :: Ptr a -> Ptr a -> Int -> IO ()
copyBytes dest src size  = do _ <- memcpy dest src (fromIntegral size)
                              return ()

-- |Copies the given number of bytes from the second area (source) into the
-- first (destination); the copied areas /may/ overlap
--
moveBytes               :: Ptr a -> Ptr a -> Int -> IO ()
moveBytes dest src size  = do _ <- memmove dest src (fromIntegral size)
                              return ()

-- Filling up memory area with required values
-- -------------------------------------------

-- |Fill a given number of bytes in memory area with a byte value.
--
-- @since 4.8.0.0
fillBytes               :: Ptr a -> Word8 -> Int -> IO ()
fillBytes dest char size = do
  _ <- memset dest (fromIntegral char) (fromIntegral size)
  return ()

-- auxiliary routines
-- -------------------

-- |Basic C routines needed for memory copying
--
foreign import ccall unsafe "string.h" memcpy  :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
foreign import ccall unsafe "string.h" memset  :: Ptr a -> CInt  -> CSize -> IO (Ptr a)