content: {- | This module defines the basic libffi machinery. You will need this to create support for new ffi types. -}
  module Foreign.LibFFI.Base where
  
  import Control.Monad
  import Data.List
  import Data.Char
  import Data.Int
  import Data.Word
  
  import Foreign.C.Types
  import Foreign.Ptr
  import Foreign.Storable
  import Foreign.C.String
  import Foreign.Marshal
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Unsafe as BSU
  
  import Foreign.LibFFI.Internal
  import Foreign.LibFFI.FFITypes
  
  newtype Arg = Arg { unArg :: IO (Ptr CType, Ptr CValue, IO ()) }
  
  customPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
  customPointerArg newA freeA a = Arg $ do
      p <- newA a
      pp <- new p
      return (ffi_type_pointer, castPtr pp, free pp >> freeA p)
  
  mkStorableArg :: Storable a => Ptr CType -> a -> Arg
  mkStorableArg cType a = Arg $ do
      p <- malloc
      poke p a
      return (cType, castPtr p, free p)
  
  data RetType a = RetType (Ptr CType) ((Ptr CValue -> IO ()) -> IO a)
  
  instance Functor RetType where
      fmap f  = withRetType (return . f)
  
  withRetType :: (a -> IO b) -> RetType a -> RetType b
  withRetType f (RetType cType withPoke)
              = RetType cType (withPoke >=> f)
  
  mkStorableRetType :: Storable a => Ptr CType -> RetType a
  mkStorableRetType cType
              = RetType cType
                  (\write -> alloca $ \ptr -> write (castPtr ptr) >> peek ptr)
  
  newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ())
  newStorableStructArgRet cTypes = do
      (cType, freeit) <- newStructCType cTypes
      return (mkStorableArg cType, mkStorableRetType cType, freeit)
  
  newStructCType  :: [Ptr CType] -> IO (Ptr CType, IO ())
  newStructCType cTypes = do
      ffi_type <- mallocBytes sizeOf_ffi_type
      elements <- newArray0 nullPtr cTypes
      init_ffi_type ffi_type elements
      return (ffi_type, free ffi_type >> free elements)
  
  callFFI :: FunPtr a -> RetType b -> [Arg] -> IO b
  callFFI funPtr (RetType cRetType withRet) args
      = allocaBytes sizeOf_cif $ \cif -> do
          (cTypes, cValues, frees) <- unzip3 `liftM` mapM unArg args
          withArray cTypes $ \cTypesPtr -> do
              status <- ffi_prep_cif cif ffi_default_abi (genericLength args) cRetType cTypesPtr
              unless (status == ffi_ok) $
                  error "callFFI: ffi_prep_cif failed"
              withArray cValues $ \cValuesPtr -> do
                  ret <- withRet (\cRet -> ffi_call cif funPtr cRet cValuesPtr)
                  sequence_ frees
                  return ret
  