{-# LANGUAGE Rank2Types #-}
{- | 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 Control.Exception
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal

import Foreign.LibFFI.Internal
import Foreign.LibFFI.FFITypes

newtype Arg = Arg { Arg -> forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
unArg :: forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a }

customPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
customPointerArg :: forall a b. (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
customPointerArg a -> IO (Ptr b)
newA Ptr b -> IO ()
freeA a
a = (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
Arg forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO a
withArg ->
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (a -> IO (Ptr b)
newA a
a) Ptr b -> IO ()
freeA forall a b. (a -> b) -> a -> b
$ \Ptr b
p ->
        forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Ptr b
p forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr b)
pp ->
            Ptr CType -> Ptr CValue -> IO a
withArg Ptr CType
ffi_type_pointer (forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr b)
pp)

mkStorableArg :: Storable a => Ptr CType -> a -> Arg
mkStorableArg :: forall a. Storable a => Ptr CType -> a -> Arg
mkStorableArg Ptr CType
cType a
a = (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
Arg forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO a
withArg ->
    forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with a
a forall a b. (a -> b) -> a -> b
$ \Ptr a
p ->
        Ptr CType -> Ptr CValue -> IO a
withArg Ptr CType
cType (forall a b. Ptr a -> Ptr b
castPtr Ptr a
p)

newtype RetType a = RetType { forall a. RetType a -> (Ptr CType -> Ptr CValue -> IO ()) -> IO a
unRetType :: (Ptr CType -> Ptr CValue -> IO ()) -> IO a }

instance Functor RetType where
    fmap :: forall a b. (a -> b) -> RetType a -> RetType b
fmap a -> b
f  = forall a b. (a -> IO b) -> RetType a -> RetType b
withRetType (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

withRetType :: (a -> IO b) -> RetType a -> RetType b
withRetType :: forall a b. (a -> IO b) -> RetType a -> RetType b
withRetType a -> IO b
f (RetType (Ptr CType -> Ptr CValue -> IO ()) -> IO a
withPoke) = forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
RetType forall a b. (a -> b) -> a -> b
$ (Ptr CType -> Ptr CValue -> IO ()) -> IO a
withPoke forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> IO b
f

mkStorableRetType :: Storable a => Ptr CType -> RetType a
mkStorableRetType :: forall a. Storable a => Ptr CType -> RetType a
mkStorableRetType Ptr CType
cType
    = forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
RetType forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO ()
write -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr a
cValue -> Ptr CType -> Ptr CValue -> IO ()
write Ptr CType
cType (forall a b. Ptr a -> Ptr b
castPtr Ptr a
cValue) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Storable a => Ptr a -> IO a
peek Ptr a
cValue

newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ())
newStorableStructArgRet :: forall a.
Storable a =>
[Ptr CType] -> IO (a -> Arg, RetType a, IO ())
newStorableStructArgRet [Ptr CType]
cTypes = do
    (Ptr CType
cType, IO ()
freeit) <- [Ptr CType] -> IO (Ptr CType, IO ())
newStructCType [Ptr CType]
cTypes
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Storable a => Ptr CType -> a -> Arg
mkStorableArg Ptr CType
cType, forall a. Storable a => Ptr CType -> RetType a
mkStorableRetType Ptr CType
cType, IO ()
freeit)

newStructCType  :: [Ptr CType] -> IO (Ptr CType, IO ())
newStructCType :: [Ptr CType] -> IO (Ptr CType, IO ())
newStructCType [Ptr CType]
cTypes = do
    Ptr CType
ffi_type <- forall a. Int -> IO (Ptr a)
mallocBytes Int
sizeOf_ffi_type
    Ptr (Ptr CType)
elements <- forall a. Storable a => a -> [a] -> IO (Ptr a)
newArray0 forall a. Ptr a
nullPtr [Ptr CType]
cTypes
    Ptr CType -> Ptr (Ptr CType) -> IO ()
init_ffi_type Ptr CType
ffi_type Ptr (Ptr CType)
elements
    forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CType
ffi_type, forall a. Ptr a -> IO ()
free Ptr CType
ffi_type forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Ptr a -> IO ()
free Ptr (Ptr CType)
elements)

sizeAndAlignmentOfCType :: Ptr CType -> IO (Int, Int)
sizeAndAlignmentOfCType :: Ptr CType -> IO (Int, Int)
sizeAndAlignmentOfCType Ptr CType
cType = do
  (CSize
size, CUShort
alignment) <- Ptr CType -> IO (CSize, CUShort)
ffi_type_size_and_alignment Ptr CType
cType
  if CSize
size forall a. Eq a => a -> a -> Bool
/= CSize
0 Bool -> Bool -> Bool
&& CUShort
alignment forall a. Eq a => a -> a -> Bool
/= CUShort
0
  then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
alignment)
  else do
    -- The type's size and alignment haven't been initialized

    -- so we force it with a call to `ffi_prep_cif`.

    C_ffi_status
status <- forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeOf_cif forall a b. (a -> b) -> a -> b
$ \Ptr CIF
cif ->
                Ptr CIF
-> C_ffi_status
-> CUInt
-> Ptr CType
-> Ptr (Ptr CType)
-> IO C_ffi_status
ffi_prep_cif Ptr CIF
cif C_ffi_status
ffi_default_abi CUInt
0 Ptr CType
cType forall a. Ptr a
nullPtr
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (C_ffi_status
status forall a. Eq a => a -> a -> Bool
== C_ffi_status
ffi_ok) forall a b. (a -> b) -> a -> b
$
      forall a. HasCallStack => [Char] -> a
error [Char]
"sizeAndAlignmentOfCType: ffi_prep_cif failed"
    (CSize
size, CUShort
alignment) <- Ptr CType -> IO (CSize, CUShort)
ffi_type_size_and_alignment Ptr CType
cType
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
alignment)

callFFI :: FunPtr a -> RetType b -> [Arg] -> IO b
callFFI :: forall a b. FunPtr a -> RetType b -> [Arg] -> IO b
callFFI FunPtr a
funPtr (RetType (Ptr CType -> Ptr CValue -> IO ()) -> IO b
actRet) [Arg]
args
    = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeOf_cif forall a b. (a -> b) -> a -> b
$ \Ptr CIF
cif ->
        forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CType)
cTypesPtr ->
            forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CValue)
cValuesPtr ->
                let
                    doCall :: IO b
doCall  = (Ptr CType -> Ptr CValue -> IO ()) -> IO b
actRet forall a b. (a -> b) -> a -> b
$ \Ptr CType
cRetType Ptr CValue
cRetValue -> do
                                C_ffi_status
status <- Ptr CIF
-> C_ffi_status
-> CUInt
-> Ptr CType
-> Ptr (Ptr CType)
-> IO C_ffi_status
ffi_prep_cif Ptr CIF
cif C_ffi_status
ffi_default_abi (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Ptr CType
cRetType Ptr (Ptr CType)
cTypesPtr
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (C_ffi_status
status forall a. Eq a => a -> a -> Bool
== C_ffi_status
ffi_ok) forall a b. (a -> b) -> a -> b
$
                                    forall a. HasCallStack => [Char] -> a
error [Char]
"callFFI: ffi_prep_cif failed"
                                forall a.
Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()
ffi_call Ptr CIF
cif FunPtr a
funPtr Ptr CValue
cRetValue Ptr (Ptr CValue)
cValuesPtr
                    addArg :: (Int, Arg) -> IO a -> IO a
addArg (Int
i, Arg forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
actArg) IO a
goArgs
                            = forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
actArg forall a b. (a -> b) -> a -> b
$ \Ptr CType
cType Ptr CValue
cValue -> do
                                forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr (Ptr CType)
cTypesPtr Int
i Ptr CType
cType
                                forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr (Ptr CValue)
cValuesPtr Int
i Ptr CValue
cValue
                                IO a
goArgs
                in
                    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. (Int, Arg) -> IO a -> IO a
addArg IO b
doCall forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Arg]
args
    where
        n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
args