fficxx-runtime 0.2.1 → 0.3

raw patch · 4 files changed

+243/−96 lines, 4 filesdep +bytestringdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, template-haskell

API changes (from Hackage documentation)

Files

• csrc/MacroPatternMatch.h +23/−0
• fficxx-runtime.cabal +6/−2
• lib/FFICXX/Runtime/Cast.hs +159/−94
• lib/FFICXX/Runtime/TH.hs +55/−0

@@ -16,5 +16,28 @@ #define IS_PAREN(x) CHECK(IS_PAREN_PROBE x) #define IS_PAREN_PROBE(...) PROBE(~) +++template<class ToType, class FromType>+const ToType* to_const(const FromType* x) {+  return reinterpret_cast<const ToType*>(x);+}++template<class ToType, class FromType>+ToType* to_nonconst(FromType* x) {+  return reinterpret_cast<ToType*>(x);+}++template<class ToType, class FromType>+const ToType& to_constref(const FromType& x) {+  return reinterpret_cast<const ToType&>(x);+}++template<class ToType, class FromType>+ToType& to_nonconstref(FromType& x) {+  return reinterpret_cast<ToType&>(x);+}++ #endif // __MACROPATTERNMATCH__  

@@ -1,5 +1,5 @@ Name:		fficxx-runtime-Version:	0.2.1+Version:	0.3 Synopsis:	Runtime for fficxx-generated library Description: 	Runtime for fficxx-generated library License:        BSD3@@ -20,10 +20,14 @@   ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind   ghc-prof-options: -caf-all -auto-all   Build-Depends: -                   base == 4.*+                 base == 4.*,+                 bytestring,+                 template-haskell    Exposed-Modules:                     FFICXX.Runtime.Cast+                   FFICXX.Runtime.TH +                      Include-dirs:    csrc   Install-includes: MacroPatternMatch.h

@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Runtime.Cast--- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2017 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -23,26 +23,29 @@  module FFICXX.Runtime.Cast where +import Control.Monad         ((>=>))+import Data.ByteString.Char8 (ByteString,packCString, useAsCString) import Data.String import Data.Word import Foreign.C import Foreign.C.String-import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+-- import System.IO.Unsafe -import System.IO.Unsafe  class IsRawType a   class Castable a b where-  cast :: a -> b -  uncast :: b -> a +  cast   :: a -> (b -> IO r) -> IO r +  uncast :: b -> (a -> IO r) -> IO r   class FPtr a where   type Raw a :: *-  get_fptr :: a -> ForeignPtr (Raw a) -  cast_fptr_to_obj :: ForeignPtr (Raw a) -> a+  get_fptr :: a -> Ptr (Raw a) +  cast_fptr_to_obj :: Ptr (Raw a) -> a   class FunPtrWrappable a where@@ -52,18 +55,9 @@   fptrWrap :: FunPtrWrapped a -> IO (FunPtr (FunPtrType a))    wrap :: FunPtrHsType a -> FunPtrWrapped a  -class Existable a where-  data Exist a :: *   -data BottomType--class GADTTypeable a where-  data GADTType a :: * -> *-  data EGADTType a :: *- class IsCType a where  - instance IsCType CChar instance IsCType CInt instance IsCType CUInt @@ -71,166 +65,205 @@ instance IsCType CULong  instance IsCType CLong -instance IsString CString where-  fromString str = unsafePerformIO (newCString str)---- cause incoherent instances but cannot avoid it now-{--instance Castable a a where-  cast = id-  uncast = id--}- instance Castable () () where-  cast = id -  uncast = id -+  cast x f = f x+  uncast x f = f x  instance Castable CDouble CDouble where-  cast = id-  uncast = id--+  cast x f = f x+  uncast x f = f x  instance Castable CUInt CUInt where-  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x    instance Castable CInt CInt where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable CLong CLong where-  cast = id-  uncast = id+  cast x f = f x +  uncast x f = f x  instance Castable CULong CULong where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x     instance Castable (Ptr CInt) (Ptr CInt) where -  cast = id -  uncast = id +  cast x f = f x+  uncast x f = f x   instance Castable (Ptr CChar) (Ptr CChar) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr CUInt) (Ptr CUInt) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr CULong) (Ptr CULong) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr CLong) (Ptr CLong) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr CDouble) (Ptr CDouble) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr CString) (Ptr CString) where -  cast = id -  uncast = id +  cast x f = f x +  uncast x f = f x   instance Castable (Ptr ()) (Ptr ()) where-  cast = id-  uncast = id+  cast x f = f x+  uncast x f = f x   instance Castable Int CInt where-  cast = fromIntegral -  uncast = fromIntegral+  cast x f = f (fromIntegral x)+  uncast x f = f (fromIntegral x)  instance Castable Word CUInt where-  cast = fromIntegral-  uncast = fromIntegral+  cast x f = f (fromIntegral x)+  uncast x f = f (fromIntegral x)  instance Castable Word8 CChar where-  cast = fromIntegral -  uncast = fromIntegral+  cast x f = f (fromIntegral x)+  uncast x f = f (fromIntegral x)    instance Castable Double CDouble where-  cast = realToFrac-  uncast = realToFrac +  cast x f = f (realToFrac x)+  uncast x f = f (realToFrac x)  instance Castable [Double] (Ptr CDouble) where-  cast xs = unsafePerformIO (newArray (map realToFrac xs))-  uncast _c_xs = undefined +  cast xs f = newArray (map realToFrac xs) >>= f +  uncast xs f = undefined   instance Castable [Int] (Ptr CInt) where-  cast xs = unsafePerformIO (newArray (map fromIntegral xs))-  uncast _c_xs = undefined +  cast xs f = newArray (map fromIntegral xs) >>= f+  uncast xs f = undefined  +instance Castable ByteString CString where+  cast x f = useAsCString x f+  uncast x f = packCString x >>= f +++instance Castable [ByteString] (Ptr CString) where+  cast xs f = do ys <- mapM (\x -> useAsCString x return) xs+                 withArray ys $ \cptr -> f cptr+  uncast xs f = undefined ++{-  instance Castable String CString where   cast x = unsafePerformIO (newCString x)   uncast x = unsafePerformIO (peekCString x)  -instance Castable [String] (Ptr CString) where-  cast xs = unsafePerformIO (mapM  newCString xs >>= newArray)-  uncast _c_xs = undefined - 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 >>= return . uncast+xformnull f = f >>= \ca -> uncast ca return  xform0 :: (Castable a ca, Castable y cy)         => (ca -> IO cy) -> a -> IO y-xform0 f a = f (cast a) >>= return . uncast +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 = f (cast a) (cast x1) >>= return . uncast +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 = f (cast a) (cast x1) (cast x2) >>= return . uncast +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 = f (cast a) (cast x1) (cast x2) (cast x3) >>= return . uncast +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 = f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) >>= return . uncast +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 = f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) >>= return . uncast +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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) -  >>= return . uncast -+  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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7)-  >>= return . uncast +  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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8)-  >>= return . uncast +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, @@ -238,8 +271,17 @@        => (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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9)-  >>= return . uncast +  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,  @@ -247,13 +289,36 @@        => (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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9) (cast x10) >>= return . uncast +  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 = -  f (cast a) (cast x1) (cast x2) (cast x3) (cast x4) (cast x5) (cast x6) (cast x7) (cast x8) (cast x9) (cast x10) (cast x11)  >>= return . uncast +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  

@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      : FFICXX.Runtime.TH+-- Copyright   : (c) 2011-2016 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Runtime.TH where++import Data.Monoid                ( (<>) )+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-------++con :: String -> Type+con = ConT . mkNameS++mkInstance :: Cxt -> Type -> [Dec] -> Dec+mkInstance = InstanceD Nothing++mkTFunc :: (Name, String, String -> String, Name -> Q Type) -> ExpQ+mkTFunc (nty, ncty, nf, tyf)+  = do let fn = nf ncty+       let fn' = "c_" <> fn+       n <- newName fn'+       d <- forImpD CCall unsafe fn n (tyf nty)+       addTopDecls [d]+       [| $( varE n ) |]++++mkMember :: String -> (Name -> String -> Q Exp) -> Name -> String -> Q Dec+mkMember fname f n ctyp = do+  let x = mkNameS "x"+  e <- f n ctyp+  return $+    FunD (mkNameS fname) [ Clause [VarP x] (NormalB (AppE e (VarE x))) [] ]++mkNew :: String -> (Name -> String -> Q Exp) -> Name -> String -> Q Dec+mkNew fname f n ctyp = do+  e <- f n ctyp+  return $+    FunD (mkNameS fname)+      [ Clause [] (NormalB e) [] ]++mkDelete :: String -> (Name -> String -> Q Exp) -> Name -> String -> Q Dec+mkDelete = mkMember