{-# LANGUAGE Rank2Types #-}
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. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg)
-> (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO a
withArg ->
IO (Ptr b) -> (Ptr b -> IO ()) -> (Ptr b -> IO a) -> IO a
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 ((Ptr b -> IO a) -> IO a) -> (Ptr b -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr b
p ->
Ptr b -> (Ptr (Ptr b) -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Ptr b
p ((Ptr (Ptr b) -> IO a) -> IO a) -> (Ptr (Ptr b) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr b)
pp ->
Ptr CType -> Ptr CValue -> IO a
withArg Ptr CType
ffi_type_pointer (Ptr (Ptr b) -> Ptr CValue
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. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg)
-> (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO a
withArg ->
a -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with a
a ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
p ->
Ptr CType -> Ptr CValue -> IO a
withArg Ptr CType
cType (Ptr a -> Ptr CValue
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 = (a -> IO b) -> RetType a -> RetType b
forall a b. (a -> IO b) -> RetType a -> RetType b
withRetType (b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (a -> b) -> a -> IO b
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) = ((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b
forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
RetType (((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b)
-> ((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b
forall a b. (a -> b) -> a -> b
$ (Ptr CType -> Ptr CValue -> IO ()) -> IO a
withPoke ((Ptr CType -> Ptr CValue -> IO ()) -> IO a)
-> (a -> IO b) -> (Ptr CType -> Ptr CValue -> IO ()) -> IO b
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
= ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
RetType (((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a)
-> ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
forall a b. (a -> b) -> a -> b
$ \Ptr CType -> Ptr CValue -> IO ()
write -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
cValue -> Ptr CType -> Ptr CValue -> IO ()
write Ptr CType
cType (Ptr a -> Ptr CValue
forall a b. Ptr a -> Ptr b
castPtr Ptr a
cValue) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr a -> IO a
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
(a -> Arg, RetType a, IO ()) -> IO (a -> Arg, RetType a, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CType -> a -> Arg
forall a. Storable a => Ptr CType -> a -> Arg
mkStorableArg Ptr CType
cType, Ptr CType -> RetType a
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 <- Int -> IO (Ptr CType)
forall a. Int -> IO (Ptr a)
mallocBytes Int
sizeOf_ffi_type
Ptr (Ptr CType)
elements <- Ptr CType -> [Ptr CType] -> IO (Ptr (Ptr CType))
forall a. Storable a => a -> [a] -> IO (Ptr a)
newArray0 Ptr CType
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
(Ptr CType, IO ()) -> IO (Ptr CType, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CType
ffi_type, Ptr CType -> IO ()
forall a. Ptr a -> IO ()
free Ptr CType
ffi_type IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr (Ptr CType) -> IO ()
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 CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
/= CSize
0 Bool -> Bool -> Bool
&& CUShort
alignment CUShort -> CUShort -> Bool
forall a. Eq a => a -> a -> Bool
/= CUShort
0
then (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, CUShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
alignment)
else do
C_ffi_status
status <- Int -> (Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeOf_cif ((Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status)
-> (Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status
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 Ptr (Ptr CType)
forall a. Ptr a
nullPtr
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (C_ffi_status
status C_ffi_status -> C_ffi_status -> Bool
forall a. Eq a => a -> a -> Bool
== C_ffi_status
ffi_ok) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
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
(Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, CUShort -> Int
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
= Int -> (Ptr CIF -> IO b) -> IO b
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeOf_cif ((Ptr CIF -> IO b) -> IO b) -> (Ptr CIF -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr CIF
cif ->
Int -> (Ptr (Ptr CType) -> IO b) -> IO b
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n ((Ptr (Ptr CType) -> IO b) -> IO b)
-> (Ptr (Ptr CType) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CType)
cTypesPtr ->
Int -> (Ptr (Ptr CValue) -> IO b) -> IO b
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n ((Ptr (Ptr CValue) -> IO b) -> IO b)
-> (Ptr (Ptr CValue) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CValue)
cValuesPtr ->
let
doCall :: IO b
doCall = (Ptr CType -> Ptr CValue -> IO ()) -> IO b
actRet ((Ptr CType -> Ptr CValue -> IO ()) -> IO b)
-> (Ptr CType -> Ptr CValue -> IO ()) -> IO b
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 (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Ptr CType
cRetType Ptr (Ptr CType)
cTypesPtr
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (C_ffi_status
status C_ffi_status -> C_ffi_status -> Bool
forall a. Eq a => a -> a -> Bool
== C_ffi_status
ffi_ok) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"callFFI: ffi_prep_cif failed"
Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()
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
= (Ptr CType -> Ptr CValue -> IO a) -> IO a
forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
actArg ((Ptr CType -> Ptr CValue -> IO a) -> IO a)
-> (Ptr CType -> Ptr CValue -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr CType
cType Ptr CValue
cValue -> do
Ptr (Ptr CType) -> Int -> Ptr CType -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr (Ptr CType)
cTypesPtr Int
i Ptr CType
cType
Ptr (Ptr CValue) -> Int -> Ptr CValue -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr (Ptr CValue)
cValuesPtr Int
i Ptr CValue
cValue
IO a
goArgs
in
((Int, Arg) -> IO b -> IO b) -> IO b -> [(Int, Arg)] -> IO b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Arg) -> IO b -> IO b
forall {a}. (Int, Arg) -> IO a -> IO a
addArg IO b
doCall ([(Int, Arg)] -> IO b) -> [(Int, Arg)] -> IO b
forall a b. (a -> b) -> a -> b
$ [Int] -> [Arg] -> [(Int, Arg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Arg]
args
where
n :: Int
n = [Arg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
args