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 { Arg -> IO (Ptr CType, Ptr CValue, IO ())
unArg :: IO (Ptr CType, Ptr CValue, IO ()) }
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 = IO (Ptr CType, Ptr CValue, IO ()) -> Arg
Arg (IO (Ptr CType, Ptr CValue, IO ()) -> Arg)
-> IO (Ptr CType, Ptr CValue, IO ()) -> Arg
forall a b. (a -> b) -> a -> b
$ do
Ptr b
p <- a -> IO (Ptr b)
newA a
a
Ptr (Ptr b)
pp <- Ptr b -> IO (Ptr (Ptr b))
forall a. Storable a => a -> IO (Ptr a)
new Ptr b
p
(Ptr CType, Ptr CValue, IO ()) -> IO (Ptr CType, Ptr CValue, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CType
ffi_type_pointer, Ptr (Ptr b) -> Ptr CValue
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr b)
pp, Ptr (Ptr b) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr b)
pp IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO ()
freeA Ptr b
p)
mkStorableArg :: Storable a => Ptr CType -> a -> Arg
mkStorableArg :: forall a. Storable a => Ptr CType -> a -> Arg
mkStorableArg Ptr CType
cType a
a = IO (Ptr CType, Ptr CValue, IO ()) -> Arg
Arg (IO (Ptr CType, Ptr CValue, IO ()) -> Arg)
-> IO (Ptr CType, Ptr CValue, IO ()) -> Arg
forall a b. (a -> b) -> a -> b
$ do
Ptr a
p <- IO (Ptr a)
forall a. Storable a => IO (Ptr a)
malloc
Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
p a
a
(Ptr CType, Ptr CValue, IO ()) -> IO (Ptr CType, Ptr CValue, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CType
cType, Ptr a -> Ptr CValue
forall a b. Ptr a -> Ptr b
castPtr Ptr a
p, Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
p)
data RetType a = RetType (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 (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
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
cType ((Ptr CValue -> IO ()) -> IO a
withPoke ((Ptr CValue -> IO ()) -> IO a)
-> (a -> IO b) -> (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
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
ptr -> Ptr CValue -> IO ()
write (Ptr a -> Ptr CValue
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) IO () -> IO a -> IO a
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
ptr)
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 (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 (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 (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)
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
cRetType (Ptr CValue -> IO ()) -> IO b
withRet) [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 -> do
([Ptr CType]
cTypes, [Ptr CValue]
cValues, [IO ()]
frees) <- [(Ptr CType, Ptr CValue, IO ())]
-> ([Ptr CType], [Ptr CValue], [IO ()])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Ptr CType, Ptr CValue, IO ())]
-> ([Ptr CType], [Ptr CValue], [IO ()]))
-> IO [(Ptr CType, Ptr CValue, IO ())]
-> IO ([Ptr CType], [Ptr CValue], [IO ()])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Arg -> IO (Ptr CType, Ptr CValue, IO ()))
-> [Arg] -> IO [(Ptr CType, Ptr CValue, IO ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Arg -> IO (Ptr CType, Ptr CValue, IO ())
unArg [Arg]
args
[Ptr CType] -> (Ptr (Ptr CType) -> IO b) -> IO b
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Ptr CType]
cTypes ((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 -> 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 ([Arg] -> CUInt
forall i a. Num i => [a] -> i
genericLength [Arg]
args) 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 CValue] -> (Ptr (Ptr CValue) -> IO b) -> IO b
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Ptr CValue]
cValues ((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 -> do
b
ret <- (Ptr CValue -> IO ()) -> IO b
withRet (\Ptr CValue
cRet -> 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
cRet Ptr (Ptr CValue)
cValuesPtr)
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
frees
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
ret