libffi++

libffi-plus.hs

{-# LANGUAGE FlexibleInstances, TypeFamilies, FlexibleContexts #-}

module Foreign.LibFFI.Call
 ( ffi
 , ffi'
 , ffiRet
 , ffiRet'
 , FFIArg(..)
 , FFIReturn(..)
 , FFI()
 ) where

import Data.ByteString (ByteString)
import qualified Data.DList as DL
import Foreign
import Foreign.C
import Foreign.LibFFI

class FFI a where
  type Result a
  call :: FunPtr f -> RetType (Result a) -> DL.DList Arg -> a

instance (FFIArg a, FFI r) => FFI (a -> r) where
  type Result (a -> r) = Result r
  call f r as a = call f r $ as `DL.snoc` arg a

instance FFI (IO r) where
  type Result (IO r) = r
  call f r = callFFI f r . DL.toList

-- turn a function pointer into the function it represents
ffi :: (FFI r, FFIReturn (Result r)) => FunPtr r -> r
ffi = ffi'

-- turn a function pointer into any function
ffi' :: (FFI r, FFIReturn (Result r)) => FunPtr a -> r
ffi' = ffiRet' ret

-- turn a function pointer into the function it represents
-- with a specific return type marshaller
ffiRet :: FFI r => RetType (Result r) -> FunPtr r -> r
ffiRet = ffiRet'

-- turn a function pointer into any function
-- with a specific return type marshaller
ffiRet' :: FFI r => RetType (Result r) -> FunPtr a -> r
ffiRet' r f = call f r DL.empty

class FFIArg a where
  arg :: a -> Arg

-- if you want to specify which Arg to use (for example for unsafe ByteString)
newtype Custom a = Custom Arg
custom :: (a -> Arg) -> a -> Custom a
custom af a = Custom $ af a

instance FFIArg (Custom a) where arg (Custom a) = a

instance FFIArg CInt where arg = argCInt
instance FFIArg CUInt where arg = argCUInt
instance FFIArg CLong where arg = argCLong
instance FFIArg CULong where arg = argCULong
instance FFIArg Int where arg = argInt
instance FFIArg Int8 where arg = argInt8
instance FFIArg Int16 where arg = argInt16
instance FFIArg Int32 where arg = argInt32
instance FFIArg Int64 where arg = argInt64
instance FFIArg Word where arg = argWord
instance FFIArg Word8 where arg = argWord8
instance FFIArg Word16 where arg = argWord16
instance FFIArg Word32 where arg = argWord32
instance FFIArg Word64 where arg = argWord64
instance FFIArg CFloat where arg = argCFloat
instance FFIArg CDouble where arg = argCDouble
instance FFIArg CSize where arg = argCSize
instance FFIArg CTime where arg = argCTime
instance FFIArg CChar where arg = argCChar
instance FFIArg CUChar where arg = argCUChar
instance FFIArg CWchar where arg = argCWchar
instance FFIArg (Ptr a) where arg = argPtr
instance FFIArg (FunPtr a) where arg = argFunPtr
instance FFIArg String where arg = argString
instance FFIArg ByteString where arg = argByteString

class FFIReturn a where
  ret :: RetType a

instance FFIReturn () where ret = retVoid
instance FFIReturn CInt where ret = retCInt
instance FFIReturn CUInt where ret = retCUInt
instance FFIReturn CLong where ret = retCLong
instance FFIReturn CULong where ret = retCULong
instance FFIReturn Int where ret = retInt
instance FFIReturn Int8 where ret = retInt8
instance FFIReturn Int16 where ret = retInt16
instance FFIReturn Int32 where ret = retInt32
instance FFIReturn Int64 where ret = retInt64
instance FFIReturn Word where ret = retWord
instance FFIReturn Word8 where ret = retWord8
instance FFIReturn Word16 where ret = retWord16
instance FFIReturn Word32 where ret = retWord32
instance FFIReturn Word64 where ret = retWord64
instance FFIReturn CFloat where ret = retCFloat
instance FFIReturn CDouble where ret = retCDouble
instance FFIReturn CSize where ret = retCSize
instance FFIReturn CTime where ret = retCTime
instance FFIReturn CChar where ret = retCChar
instance FFIReturn CUChar where ret = retCUChar
instance FFIReturn CWchar where ret = retCWchar
instance FFIReturn a => FFIReturn (Ptr a) where ret = retPtr ret
instance FFIReturn a => FFIReturn (FunPtr a) where ret = retFunPtr ret
instance FFIReturn CString where ret = retCString
instance FFIReturn String where ret = retString
instance FFIReturn ByteString where ret = retByteString