{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module FFICXX.Runtime.Cast where
import Data.ByteString.Char8 (ByteString,packCString, useAsCString)
import Data.Word
import Data.Int
import Foreign.C
import Foreign.Marshal.Array
import Foreign.Ptr
class IsRawType a
class Castable a b where
cast :: a -> (b -> IO r) -> IO r
uncast :: b -> (a -> IO r) -> IO r
class FPtr a where
type Raw a :: *
get_fptr :: a -> Ptr (Raw a)
cast_fptr_to_obj :: Ptr (Raw a) -> a
class FunPtrWrappable a where
type FunPtrHsType a :: *
type FunPtrType a :: *
data FunPtrWrapped a :: *
fptrWrap :: FunPtrWrapped a -> IO (FunPtr (FunPtrType a))
wrap :: FunPtrHsType a -> FunPtrWrapped a
class IsCType a where
instance IsCType CBool
instance IsCType CChar
instance IsCType CClock
instance IsCType CDouble
instance IsCType CFile
instance IsCType CFloat
instance IsCType CFpos
instance IsCType CInt
instance IsCType CIntMax
instance IsCType CIntPtr
instance IsCType CJmpBuf
instance IsCType CLLong
instance IsCType CLong
instance IsCType CPtrdiff
instance IsCType CSChar
instance IsCType CSUSeconds
instance IsCType CShort
instance IsCType CSigAtomic
instance IsCType CSize
instance IsCType CTime
instance IsCType CUChar
instance IsCType CUInt
instance IsCType CUIntMax
instance IsCType CUIntPtr
instance IsCType CULLong
instance IsCType CULong
instance IsCType CUSeconds
instance IsCType CUShort
instance IsCType CWchar
instance IsCType CString
instance IsCType Int8
instance IsCType Int16
instance IsCType Int32
instance IsCType Int64
instance IsCType Word8
instance IsCType Word16
instance IsCType Word32
instance IsCType Word64
instance Castable () () where
cast x f = f x
uncast x f = f x
instance Castable CBool CBool where
cast x f = f x
uncast x f = f x
instance Castable CChar CChar where
cast x f = f x
uncast x f = f x
instance Castable CClock CClock where
cast x f = f x
uncast x f = f x
instance Castable CDouble CDouble where
cast x f = f x
uncast x f = f x
instance Castable CFile CFile where
cast x f = f x
uncast x f = f x
instance Castable CFloat CFloat where
cast x f = f x
uncast x f = f x
instance Castable CFpos CFpos where
cast x f = f x
uncast x f = f x
instance Castable CInt CInt where
cast x f = f x
uncast x f = f x
instance Castable CIntMax CIntMax where
cast x f = f x
uncast x f = f x
instance Castable CIntPtr CIntPtr where
cast x f = f x
uncast x f = f x
instance Castable CJmpBuf CJmpBuf where
cast x f = f x
uncast x f = f x
instance Castable CLLong CLLong where
cast x f = f x
uncast x f = f x
instance Castable CLong CLong where
cast x f = f x
uncast x f = f x
instance Castable CPtrdiff CPtrdiff where
cast x f = f x
uncast x f = f x
instance Castable CSChar CSChar where
cast x f = f x
uncast x f = f x
instance Castable CSUSeconds CSUSeconds where
cast x f = f x
uncast x f = f x
instance Castable CShort CShort where
cast x f = f x
uncast x f = f x
instance Castable CSigAtomic CSigAtomic where
cast x f = f x
uncast x f = f x
instance Castable CSize CSize where
cast x f = f x
uncast x f = f x
instance Castable CTime CTime where
cast x f = f x
uncast x f = f x
instance Castable CUChar CUChar where
cast x f = f x
uncast x f = f x
instance Castable CUInt CUInt where
cast x f = f x
uncast x f = f x
instance Castable CUIntMax CUIntMax where
cast x f = f x
uncast x f = f x
instance Castable CUIntPtr CUIntPtr where
cast x f = f x
uncast x f = f x
instance Castable CULLong CULLong where
cast x f = f x
uncast x f = f x
instance Castable CULong CULong where
cast x f = f x
uncast x f = f x
instance Castable CUSeconds CUSeconds where
cast x f = f x
uncast x f = f x
instance Castable CUShort CUShort where
cast x f = f x
uncast x f = f x
instance Castable CWchar CWchar where
cast x f = f x
uncast x f = f x
instance Castable Int8 Int8 where
cast x f = f x
uncast x f = f x
instance Castable Int16 Int16 where
cast x f = f x
uncast x f = f x
instance Castable Int32 Int32 where
cast x f = f x
uncast x f = f x
instance Castable Int64 Int64 where
cast x f = f x
uncast x f = f x
instance Castable Word8 Word8 where
cast x f = f x
uncast x f = f x
instance Castable Word16 Word16 where
cast x f = f x
uncast x f = f x
instance Castable Word32 Word32 where
cast x f = f x
uncast x f = f x
instance Castable Word64 Word64 where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CInt) (Ptr CInt) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CChar) (Ptr CChar) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CUInt) (Ptr CUInt) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CULong) (Ptr CULong) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CLong) (Ptr CLong) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CDouble) (Ptr CDouble) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr CString) (Ptr CString) where
cast x f = f x
uncast x f = f x
instance Castable (Ptr ()) (Ptr ()) where
cast x f = f x
uncast x f = f x
instance Castable Int CInt where
cast x f = f (fromIntegral x)
uncast x f = f (fromIntegral x)
instance Castable Int16 CShort where
cast x f = f (fromIntegral x)
uncast x f = f (fromIntegral x)
instance Castable Int8 CChar where
cast x f = f (fromIntegral x)
uncast x f = f (fromIntegral x)
instance Castable Word CUInt where
cast x f = f (fromIntegral x)
uncast x f = f (fromIntegral x)
instance Castable Word8 CChar where
cast x f = f (fromIntegral x)
uncast x f = f (fromIntegral x)
instance Castable Double CDouble where
cast x f = f (realToFrac x)
uncast x f = f (realToFrac x)
-- TODO: remove this
instance Castable [Double] (Ptr CDouble) where
cast xs f = newArray (map realToFrac xs) >>= f
uncast _ _ = undefined
-- TODO: remove this
instance Castable [Int] (Ptr CInt) where
cast xs f = newArray (map fromIntegral xs) >>= f
uncast _ _ = undefined
instance Castable ByteString CString where
cast x f = useAsCString x f
uncast x f = packCString x >>= f
-- TODO: remove this
instance Castable [ByteString] (Ptr CString) where
cast xs f = do ys <- mapM (\x -> useAsCString x return) xs
withArray ys $ \cptr -> f cptr
uncast _ _ = undefined
{-
instance Castable String CString where
cast x = unsafePerformIO (newCString x)
uncast x = unsafePerformIO (peekCString x)
instance (Castable a a', Castable b b') => Castable (a->b) (a'->b') where
cast f = cast . f . uncast
uncast f = uncast . f . cast
-}
xformnull :: (Castable a ca) => (IO ca) -> IO a
xformnull f = f >>= \ca -> uncast ca return
xform0 :: (Castable a ca, Castable y cy)
=> (ca -> IO cy) -> a -> IO y
xform0 f a = cast a $ \ca -> f ca >>= \cy -> uncast cy return
xform1 :: (Castable a ca, Castable x1 cx1, Castable y cy)
=> (ca -> cx1 -> IO cy) -> a -> x1 -> IO y
xform1 f a x1 = cast a $ \ca ->
cast x1 $ \cx1 ->
f ca cx1 >>= \cy -> uncast cy return
xform2 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable y cy)
=> (ca -> cx1 -> cx2 -> IO cy) -> a -> x1 -> x2-> IO y
xform2 f a x1 x2 = cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
f ca cx1 cx2 >>= \cy -> uncast cy return
xform3 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> IO cy) -> a -> x1 -> x2 -> x3 -> IO y
xform3 f a x1 x2 x3 = cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
f ca cx1 cx2 cx3 >>= \cy -> uncast cy return
xform4 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> IO cy) -> a -> x1 -> x2 -> x3 -> x4 -> IO y
xform4 f a x1 x2 x3 x4 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
f ca cx1 cx2 cx3 cx4 >>= \cy -> uncast cy return
xform5 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> IO cy) -> a -> x1 -> x2 -> x3 -> x4 -> x5 -> IO y
xform5 f a x1 x2 x3 x4 x5 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
f ca cx1 cx2 cx3 cx4 cx5 >>= \cy -> uncast cy return
xform6 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> IO y
xform6 f a x1 x2 x3 x4 x5 x6 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 >>= \cy -> uncast cy return
xform7 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> IO y
xform7 f a x1 x2 x3 x4 x5 x6 x7 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
cast x7 $ \cx7 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 >>= \cy -> uncast cy return
xform8 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> IO y
xform8 f a x1 x2 x3 x4 x5 x6 x7 x8 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
cast x7 $ \cx7 ->
cast x8 $ \cx8 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 cx8 >>= \cy -> uncast cy return
xform9 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9,
Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> IO y
xform9 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
cast x7 $ \cx7 ->
cast x8 $ \cx8 ->
cast x9 $ \cx9 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 cx8 cx9 >>= \cy -> uncast cy return
xform10 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9,
Castable x10 cx10, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> cx10 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> x10 -> IO y
xform10 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
cast x7 $ \cx7 ->
cast x8 $ \cx8 ->
cast x9 $ \cx9 ->
cast x10 $ \cx10 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 cx8 cx9 cx10 >>= \cy -> uncast cy return
xform11 :: (Castable a ca, Castable x1 cx1, Castable x2 cx2, Castable x3 cx3, Castable x4 cx4,
Castable x5 cx5, Castable x6 cx6, Castable x7 cx7, Castable x8 cx8, Castable x9 cx9,
Castable x10 cx10, Castable x11 cx11, Castable y cy)
=> (ca -> cx1 -> cx2 -> cx3 -> cx4 -> cx5 -> cx6 -> cx7 -> cx8 -> cx9 -> cx10 -> cx11 -> IO cy)
-> a -> x1 -> x2 -> x3 -> x4 -> x5 -> x6 -> x7 -> x8 -> x9 -> x10 -> x11 -> IO y
xform11 f a x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 =
cast a $ \ca ->
cast x1 $ \cx1 ->
cast x2 $ \cx2 ->
cast x3 $ \cx3 ->
cast x4 $ \cx4 ->
cast x5 $ \cx5 ->
cast x6 $ \cx6 ->
cast x7 $ \cx7 ->
cast x8 $ \cx8 ->
cast x9 $ \cx9 ->
cast x10 $ \cx10 ->
cast x11 $ \cx11 ->
f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 cx8 cx9 cx10 cx11 >>= \cy -> uncast cy return