diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2013, Ian-Woo Kim. All rights reserved. +Copyright 2011-2019, Ian-Woo Kim. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,10 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> import Distribution.PackageDescription -> --import System.Process -> main = defaultMain -> --main = defaultMainWithHooks testUserHooks -> --testUserHooks = simpleUserHooks { -> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo -> -- } diff --git a/csrc/MacroPatternMatch.h b/csrc/MacroPatternMatch.h --- a/csrc/MacroPatternMatch.h +++ b/csrc/MacroPatternMatch.h @@ -1,43 +1,61 @@ #ifndef __MACROPATTERNMATCH__ -#define __MACROPATTERNMATCH__ +#define __MACROPATTERNMATCH__ -#define CAT(a,...) PRIMITIVE_CAT(a, __VA_ARGS__ ) -#define PRIMITIVE_CAT(a,...) a ## __VA_ARGS__ - -#define IIF(c) PRIMITIVE_CAT(IIF_, c) -#define IIF_0(t, ...) __VA_ARGS__ -#define IIF_1(t, ...) t +#define FXCAT(a,...) FXPRIMITIVE_CAT(a, __VA_ARGS__ ) +#define FXPRIMITIVE_CAT(a,...) a ## __VA_ARGS__ -#define CHECK_N(x, n, ... ) n -#define CHECK(...) CHECK_N (__VA_ARGS__, 0, ) -#define PROBE(x) x, 1, +#define FXIIF(c) FXPRIMITIVE_CAT(FXIIF_, c) +#define FXIIF_0(t, ...) __VA_ARGS__ +#define FXIIF_1(t, ...) t -#define IS_PAREN(x) CHECK(IS_PAREN_PROBE x) -#define IS_PAREN_PROBE(...) PROBE(~) +#define FXCHECK_N(x, n, ... ) n +#define FXCHECK(...) FXCHECK_N (__VA_ARGS__, 0, ) +#define FXPROBE(x) x, 1, +#define FXIS_PAREN(x) FXCHECK(FXIS_PAREN_PROBE x) +#define FXIS_PAREN_PROBE(...) FXPROBE(~) template -const ToType* to_const(const FromType* x) { +const ToType* from_const_to_const(const FromType* x) { return reinterpret_cast(x); } template -ToType* to_nonconst(FromType* x) { +ToType* from_nonconst_to_nonconst(FromType* x) { return reinterpret_cast(x); } template -const ToType& to_constref(const FromType& x) { +ToType* from_const_to_nonconst(const FromType* x) { + return reinterpret_cast(const_cast(x)); +} + +template +const ToType* from_nonconst_to_const(FromType* x) { + return const_cast(reinterpret_cast(x)); +} + +template +const ToType& from_constref_to_constref(const FromType& x) { return reinterpret_cast(x); } template -ToType& to_nonconstref(FromType& x) { +ToType& from_nonconstref_to_nonconstref(FromType& x) { return reinterpret_cast(x); } +template +ToType& from_constref_to_nonconstref(const FromType& x) { + return reinterpret_cast(x); +} -#endif // __MACROPATTERNMATCH__ +template +ToType& from_nonconstref_to_constref(FromType& x) { + return const_cast(reinterpret_cast(x)); +} + +#endif // __MACROPATTERNMATCH__ diff --git a/fficxx-runtime.cabal b/fficxx-runtime.cabal --- a/fficxx-runtime.cabal +++ b/fficxx-runtime.cabal @@ -1,14 +1,15 @@ -Name: fficxx-runtime -Version: 0.5 -Synopsis: Runtime for fficxx-generated library -Description: Runtime for fficxx-generated library +Name: fficxx-runtime +Version: 0.6 +Synopsis: Runtime for fficxx-generated library +Description: Runtime for fficxx-generated library. + fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. License: BSD3 -License-file: LICENSE -Author: Ian-Woo Kim -Maintainer: Ian-Woo Kim -Build-Type: Simple +License-file: LICENSE +Author: Ian-Woo Kim +Maintainer: Ian-Woo Kim +Build-Type: Simple Category: FFI Tools -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Data-files: Source-repository head @@ -16,19 +17,21 @@ location: http://www.github.com/wavewave/fficxx-runtime Library - hs-source-dirs: lib - ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind - ghc-prof-options: -caf-all -auto-all + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind Build-Depends: base == 4.*, bytestring, + hashable, template-haskell Exposed-Modules: FFICXX.Runtime.Cast - FFICXX.Runtime.TH + FFICXX.Runtime.CodeGen.Cxx FFICXX.Runtime.Function.Template FFICXX.Runtime.Function.TH + FFICXX.Runtime.TH Include-dirs: csrc diff --git a/lib/FFICXX/Runtime/Cast.hs b/lib/FFICXX/Runtime/Cast.hs deleted file mode 100644 --- a/lib/FFICXX/Runtime/Cast.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Runtime.Cast --- Copyright : (c) 2011-2017 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -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.ForeignPtr -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable --- import System.IO.Unsafe - - -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 CChar -instance IsCType CInt -instance IsCType CUInt -instance IsCType CString -instance IsCType CULong -instance IsCType CLong - -instance Castable () () 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 CUInt CUInt 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 CLong CLong 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 (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 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) - -instance Castable [Double] (Ptr CDouble) where - cast xs f = newArray (map realToFrac xs) >>= f - uncast xs f = undefined - -instance Castable [Int] (Ptr CInt) where - 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 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 - diff --git a/lib/FFICXX/Runtime/Function/TH.hs b/lib/FFICXX/Runtime/Function/TH.hs deleted file mode 100644 --- a/lib/FFICXX/Runtime/Function/TH.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module FFICXX.Runtime.Function.TH where -import Data.Char -import Data.Monoid -import Foreign.C.Types -import Foreign.Ptr -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import FFICXX.Runtime.TH -import FFICXX.Runtime.Function.Template - - -mkWrapper :: (Type,String) -> Q Dec -mkWrapper (typ,suffix) - = do let fn = "wrap_" <> suffix - n <- newName fn - d <- forImpD CCall safe "wrapper" n [t| $(pure typ) -> IO (FunPtr ($(pure typ))) |] - addTopDecls [d] - pure $ - FunD (mkNameS "wrapFunPtr") [ Clause [] (NormalB (VarE n)) [] ] - - -t_newFunction :: Type -> String -> ExpQ -t_newFunction typ suffix - = mkTFunc (typ, suffix, \ n -> "Function_new_" <> n, tyf) - where tyf n = - let t = pure typ - in [t| FunPtr $( t ) -> IO (Function $( t )) |] - -t_call :: Type -> String -> ExpQ -t_call typ suffix - = mkTFunc (typ, suffix, \ n -> "Function_call_" <> n, tyf) - where tyf n = - let t = pure typ - in [t| Function $( t ) -> $( t ) |] - -t_deleteFunction :: Type -> String -> ExpQ -t_deleteFunction typ suffix - = mkTFunc (typ, suffix, \ n -> "Function_delete_" <> n, tyf) - where tyf n = - let t = pure typ - in [t| Function $( t ) -> IO () |] - - -genFunctionInstanceFor :: Q Type -> String -> Q [Dec] -genFunctionInstanceFor qtyp suffix - = do typ <- qtyp - f1 <- mkNew "newFunction" t_newFunction typ suffix - f2 <- mkMember "call" t_call typ suffix - f3 <- mkMember "deleteFunction" t_deleteFunction typ suffix - wrap <- mkWrapper (typ,suffix) - let lst = [f1,f2,f3] - return [ mkInstance [] (AppT (con "IFunction") typ) lst - , mkInstance [] (AppT (con "FunPtrWrapper") typ) [wrap] - ] diff --git a/lib/FFICXX/Runtime/Function/Template.hs b/lib/FFICXX/Runtime/Function/Template.hs deleted file mode 100644 --- a/lib/FFICXX/Runtime/Function/Template.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, FlexibleInstances, - MultiParamTypeClasses, TypeFamilies #-} -module FFICXX.Runtime.Function.Template where -import Foreign.C.Types -import Foreign.Ptr -import FFICXX.Runtime.Cast - -data RawFunction t - -newtype Function t = Function (Ptr (RawFunction t)) - -class () => IFunction t where - newFunction :: FunPtr t -> IO (Function t) - call :: Function t -> t - deleteFunction :: Function t -> IO () - -instance () => FPtr (Function t) where - type Raw (Function t) = RawFunction t - get_fptr (Function ptr) = ptr - cast_fptr_to_obj = Function - -instance () => Castable (Function t) (Ptr (RawFunction t)) where - cast x f = f (castPtr (get_fptr x)) - uncast x f = f (cast_fptr_to_obj (castPtr x)) - - -instance () => Castable (FunPtr t) (FunPtr t) where - cast x f = f x - uncast x f = f x - - -class () => FunPtrWrapper t where - wrapFunPtr :: t -> IO (FunPtr t) diff --git a/lib/FFICXX/Runtime/TH.hs b/lib/FFICXX/Runtime/TH.hs deleted file mode 100644 --- a/lib/FFICXX/Runtime/TH.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Runtime.TH --- Copyright : (c) 2011-2016 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- 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 :: (Type, String, String -> String, Type -> Q Type) -> Q Exp -mkTFunc (typ, suffix, nf, tyf) - = do let fn = nf suffix - let fn' = "c_" <> fn - n <- newName fn' - d <- forImpD CCall safe fn n (tyf typ) - addTopDecls [d] - [| $( varE n ) |] - - -mkMember :: String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec -mkMember fname f typ suffix = do - let x = mkNameS "x" - e <- f typ suffix - pure $ - FunD (mkNameS fname) [ Clause [VarP x] (NormalB (AppE e (VarE x))) [] ] - - -mkNew :: String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec -mkNew fname f typ suffix = do - e <- f typ suffix - pure $ - FunD (mkNameS fname) - [ Clause [] (NormalB e) [] ] - - -mkDelete :: String -> (Type -> String -> Q Exp) -> Type -> String -> Q Dec -mkDelete = mkMember diff --git a/src/FFICXX/Runtime/Cast.hs b/src/FFICXX/Runtime/Cast.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Runtime/Cast.hs @@ -0,0 +1,475 @@ +{-# 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 diff --git a/src/FFICXX/Runtime/CodeGen/Cxx.hs b/src/FFICXX/Runtime/CodeGen/Cxx.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Runtime/CodeGen/Cxx.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} + +module FFICXX.Runtime.CodeGen.Cxx where + +import Data.Functor.Identity (Identity) +import Data.Hashable ( Hashable ) +import Data.List ( intercalate ) +import Data.Semigroup ( (<>) ) +import Data.String ( IsString(..) ) + + +newtype HeaderName = + HdrName { unHdrName :: String } + deriving (Hashable, Show, Eq, Ord) + + +instance IsString HeaderName where + fromString = HdrName + +newtype Namespace = + NS { unNamespace :: String } + deriving (Show,Eq,Ord) + +instance IsString Namespace where + fromString = NS + +data PragmaParam = Once + +-- | parts for interpolation +newtype NamePart (f :: * -> *) = NamePart String + +newtype CName (f :: * -> *) = CName [NamePart f] + +sname :: String -> CName Identity +sname s = CName [NamePart s] + +renderCName :: CName Identity -> String +renderCName (CName ps) = intercalate "##" $ map (\(NamePart p) -> p) ps + +-- | Types +data CType (f :: * -> *) = + CTVoid + | CTSimple (CName f) + | CTStar (CType f) + | CTAuto + | CTTApp -- template type T + (CName f) -- ^ template type name + [ CType f ] -- ^ template parameters + | CTConst (CType f) + | CTScoped (CType f) (CType f) -- some_class::inner_class + -- TODO: refine this by restriction + | CTVerbatim String + +-- | Operators +data COp = CArrow | CAssign + +renderCOp :: COp -> String +renderCOp CArrow = "->" +renderCOp CAssign = "=" + +data CExp (f :: * -> *) = + CVar (CName f) -- ^ variable + | CApp (CExp f) [CExp f] -- ^ C function app: f(a1,a2,..) + | CTApp (CName f) [CType f] [CExp f] -- ^ template app : f(a1,a2,..) + | CBinOp COp (CExp f) (CExp f) -- ^ binary operator: x `op` y + | CCast (CType f) (CExp f) -- ^ (type)exp + | CAddr (CExp f) -- ^ &(exp) + | CStar (CExp f) -- ^ *(exp) + | CNew (CName f) [CExp f] -- ^ new operator: new Cstr(a1,a2,...) + | CTNew (CName f) [CType f] [CExp f] -- ^ new operator for template class: new Cstr(a1,a2,..) + | CTNewI (CName f) (CName f) [CType f] [CExp f] -- ^ new operator for inner class of template class: new Cstr::inner(a1,a2,..) -- TODO: make a generalization + | CEMacroApp (CName f) [CName f] -- ^ macro function at expression level + | CEVerbatim String -- ^ verbatim + | CNull -- ^ empty C expression. (for convenience) + +data CFunDecl (f :: * -> *) = + CFunDecl (CType f) (CName f) [(CType f,CName f)] -- ^ type func( type1 arg1, type2 arg2, ... ) + +data CVarDecl (f :: * -> *) = + CVarDecl + (CType f) -- ^ type + (CName f) -- ^ variable name + +data CQual = Inline + +data CStatement (f :: * -> *) = + UsingNamespace Namespace -- ^ using namespace ; + | TypeDef (CType f) (CName f) -- ^ typedef origtype newname; + | CExpSA (CExp f) -- ^ C expression standalone; + | CDeclaration (CFunDecl f) -- ^ function declaration; + | CDefinition (Maybe CQual) (CFunDecl f) [CStatement f] + -- ^ function definition; + | CInit (CVarDecl f) (CExp f) -- ^ variable initialization; + | CReturn (CExp f) -- ^ return statement; + | CDelete (CExp f) -- ^ delete statement; + | CMacroApp (CName f) [CName f] -- ^ C Macro application at statement level (temporary) + | CExtern [CStatement f] -- ^ extern "C" {..} + | Comment String -- ^ comment + | CEmptyLine -- ^ for convenience + | CVerbatim String -- ^ temporary verbatim + +data CMacro (f :: * -> *) = + CRegular (CStatement f) -- ^ regular C++ statement + | Include HeaderName -- ^ #include "
" + | Pragma PragmaParam -- ^ #pragma + | Undef (CName f) -- ^ #undef name + | Define (CName f) [CName f] [CStatement f] -- ^ #define macro (type) definition + | EmptyLine -- ^ just for convenience + | Verbatim String -- ^ temporary verbatim + +data CBlock (f :: * -> *) = ExternC [CMacro f] -- extern "C" with #ifdef __cplusplus guard. + +renderPragmaParam :: PragmaParam -> String +renderPragmaParam Once = "once" + +renderCType :: CType Identity -> String +renderCType CTVoid = "void" +renderCType (CTSimple n) = renderCName n +renderCType (CTStar t) = renderCType t <> "*" +renderCType CTAuto = "auto" +renderCType (CTTApp n ts) = renderCName n <> "<" <> intercalate ", " (map renderCType ts) <> ">" +renderCType (CTConst t) = "const " <> renderCType t +renderCType (CTScoped t i) = renderCType t <> "::" <> renderCType i +renderCType (CTVerbatim t) = t + +renderCExp :: CExp Identity -> String +renderCExp (CVar n) = renderCName n +renderCExp (CApp f es) = (case f of + CVar _ -> renderCExp f + _ -> "(" <> renderCExp f <> ")" -- compound expression like (*p) + ) + <> "(" + <> intercalate ", " (map renderCExp es) -- arguments + <> ")" +renderCExp (CTApp f ts es) = renderCName f + <> "<" + <> intercalate ", " (map renderCType ts) -- type arguments + <> ">" + <> "(" + <> intercalate ", " (map renderCExp es) -- arguments + <> ")" +renderCExp (CBinOp o x y) = (case x of + CVar _ -> renderCExp x + _ -> "(" <> renderCExp x <> ")" -- compound expression like (*p) + ) + <> renderCOp o + <> renderCExp y +renderCExp (CCast t e) = "(" <> renderCType t <> ")" <> renderCExp e +renderCExp (CAddr e) = "&(" <> renderCExp e <> ")" +renderCExp (CStar e) = "*(" <> renderCExp e <> ")" +renderCExp (CNew n es) = "new " + <> renderCName n -- constructor name + <> "(" + <> intercalate ", " (map renderCExp es) -- arguments + <> ")" +renderCExp (CTNew n ts es) = "new " + <> renderCName n -- constructor name + <> "<" + <> intercalate ", " (map renderCType ts) -- type arguments + <> ">" + <> "(" + <> intercalate ", " (map renderCExp es) -- arguments + <> ")" +renderCExp (CTNewI n i ts es) = "new " + <> renderCName n -- constructor name + <> "<" + <> intercalate ", " (map renderCType ts) -- type arguments + <> ">::" + <> renderCName i -- inner class name + <> "(" + <> intercalate ", " (map renderCExp es) -- arguments + <> ")" +renderCExp (CEMacroApp n as) = renderCName n + <> "(" + <> intercalate ", " (map renderCName as) + <> ")" -- NOTE: no semicolon. +renderCExp (CEVerbatim e) = e +renderCExp CNull = "" + +renderCQual :: CQual -> String +renderCQual Inline = "inline" + +renderCFDecl :: CFunDecl Identity -> String +renderCFDecl (CFunDecl typ fname args) = + renderCType typ <> " " <> renderCName fname <> " ( " <> intercalate ", " (map mkArgStr args) <> " )" + where + mkArgStr (t, a) = renderCType t <> " " <> renderCName a + +renderCVDecl :: CVarDecl Identity -> String +renderCVDecl (CVarDecl typ vname) = renderCType typ <> " " <> renderCName vname + +-- | render CStatement in a regular environment +renderCStmt :: CStatement Identity -> String +renderCStmt (UsingNamespace (NS ns)) = "using namespace " <> ns <> ";" +renderCStmt (TypeDef typ n) = "typedef " <> renderCType typ <> " " <> renderCName n <> ";" +renderCStmt (CExpSA e) = renderCExp e <> ";" +renderCStmt (CDeclaration e) = renderCFDecl e <> ";" +renderCStmt (CDefinition mq d body) = maybe "" (\q -> renderCQual q <> " ") mq + <> renderCFDecl d + <> " {\n" + <> concatMap renderCStmt body + <> "\n}\n" +renderCStmt (CInit d e) = renderCVDecl d <> "=" <> renderCExp e <> ";" +renderCStmt (CReturn e) = "return " <> renderCExp e <> ";" +renderCStmt (CDelete e) = "delete " <> renderCExp e <> ";" +renderCStmt (CMacroApp n as) = renderCName n + <> "(" + <> intercalate ", " (map renderCName as) + <> ")" -- NOTE: no semicolon. +renderCStmt (CExtern body) = "extern \"C\" {\n" + <> concatMap renderCStmt body + <> "}\n" +renderCStmt (Comment str) = "// " <> str <> "\n" +renderCStmt CEmptyLine = "\n" +renderCStmt (CVerbatim str) = str + +-- | render CStatement in a macro definition environment +renderCStmtInMacro :: CStatement Identity -> [String] +renderCStmtInMacro (Comment _str) = [""] -- Comment cannot exist in Macro +renderCStmtInMacro CEmptyLine = [""] +renderCStmtInMacro (CVerbatim str) = lines str +renderCStmtInMacro s = lines (renderCStmt s) + +renderCMacro :: CMacro Identity -> String +renderCMacro (CRegular stmt) = renderCStmt stmt +renderCMacro (Include (HdrName hdr)) = "\n#include \"" <> hdr <> "\"\n" +renderCMacro (Pragma param) = "\n#pragma " <> renderPragmaParam param <> "\n" +renderCMacro (Undef n) = "\n#undef " <> renderCName n <> "\n" +renderCMacro (Define m ts stmts) = + "\n#define " <> renderCName m + <> case ts of + [] -> " " + _ -> "(" <> intercalate ", " (map renderCName ts) <> ") \\\n" + <> intercalate "\\\n" (concatMap renderCStmtInMacro stmts) + <> "\n" +renderCMacro EmptyLine = "\n" +renderCMacro (Verbatim str) = str + + +renderBlock :: CBlock Identity -> String +renderBlock (ExternC ms) = + "\n#ifdef __cplusplus\n\ + \extern \"C\" {\n\ + \#endif\n" + ++ concatMap renderCMacro ms + ++ "\n#ifdef __cplusplus\n\ + \}\n\ + \#endif\n" diff --git a/src/FFICXX/Runtime/Function/TH.hs b/src/FFICXX/Runtime/Function/TH.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Runtime/Function/TH.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE TemplateHaskell #-} +module FFICXX.Runtime.Function.TH where + +import Data.List ( intercalate ) +import Data.Maybe ( fromMaybe ) +import Foreign.Ptr ( FunPtr ) +import Language.Haskell.TH ( forImpD, safe ) +import Language.Haskell.TH.Syntax ( Body(NormalB), Callconv(CCall), Clause(..) + , Exp(..), Dec(..), ForeignSrcLang(LangCxx) + , Q, Type(..) + , addForeignSource + , addModFinalizer + , addTopDecls + , mkNameS + , newName + ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( CMacro(..), CStatement(..), renderCMacro, renderCStmt ) +import FFICXX.Runtime.TH ( FunctionParamInfo(..) + , con, mkInstance, mkMember, mkNew, mkTFunc + ) +import FFICXX.Runtime.Function.Template ( Function ) + + +mkWrapper :: (Type,String) -> Q Dec +mkWrapper (typ,suffix) + = do let fn = "wrap_" <> suffix + n <- newName fn + d <- forImpD CCall safe "wrapper" n [t| $(pure typ) -> IO (FunPtr ($(pure typ))) |] + addTopDecls [d] + pure $ + FunD (mkNameS "wrapFunPtr") [ Clause [] (NormalB (VarE n)) [] ] + + +t_newFunction :: Type -> String -> Q Exp +t_newFunction typ suffix + = mkTFunc (typ, suffix, \ n -> "Function_new_" <> n, tyf) + where tyf _n = + let t = pure typ + in [t| FunPtr $( t ) -> IO (Function $( t )) |] + +t_call :: Type -> String -> Q Exp +t_call typ suffix + = mkTFunc (typ, suffix, \ n -> "Function_call_" <> n, tyf) + where tyf _n = + let t = pure typ + in [t| Function $( t ) -> $( t ) |] + +t_deleteFunction :: Type -> String -> Q Exp +t_deleteFunction typ suffix + = mkTFunc (typ, suffix, \ n -> "Function_delete_" <> n, tyf) + where tyf _n = + let t = pure typ + in [t| Function $( t ) -> IO () |] + + +genFunctionInstanceFor :: Q Type -> FunctionParamInfo -> Q [Dec] +genFunctionInstanceFor qtyp param + = do let suffix = fpinfoSuffix param + typ <- qtyp + f1 <- mkNew "newFunction" t_newFunction typ suffix + f2 <- mkMember "call" t_call typ suffix + f3 <- mkMember "deleteFunction" t_deleteFunction typ suffix + wrap <- mkWrapper (typ,suffix) + addModFinalizer + (addForeignSource LangCxx + ("\n#include \"functional\"\n\n\n#include \"Function.h\"\n\n" + ++ (let headers = fpinfoCxxHeaders param + f x = renderCMacro (Include x) + in concatMap f headers + ) + ++ (let nss = fpinfoCxxNamespaces param + f x = renderCStmt (UsingNamespace x) + in concatMap f nss + ) + ++ (let retstr = fromMaybe "void" (fpinfoCxxRetType param) + argstr = let args = fpinfoCxxArgTypes param + vs = case args of + [] -> "(,)" + _ -> intercalate "," $ + map (\(t,x) -> "(" ++ t ++ "," ++ x ++ ")") args + in "(" ++ vs ++ ")" + in "Function(" ++ suffix ++ "," ++ retstr ++ "," ++ argstr ++ ")\n" + ) + ) + ) + let lst = [f1,f2,f3] + return [ mkInstance [] (AppT (con "IFunction") typ) lst + , mkInstance [] (AppT (con "FunPtrWrapper") typ) [wrap] + ] diff --git a/src/FFICXX/Runtime/Function/Template.hs b/src/FFICXX/Runtime/Function/Template.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Runtime/Function/Template.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module FFICXX.Runtime.Function.Template where +import Foreign.Ptr +import FFICXX.Runtime.Cast + + +data RawFunction t + +newtype Function t = Function (Ptr (RawFunction t)) + +class () => IFunction t where + newFunction :: FunPtr t -> IO (Function t) + call :: Function t -> t + deleteFunction :: Function t -> IO () + +instance () => FPtr (Function t) where + type Raw (Function t) = RawFunction t + get_fptr (Function ptr) = ptr + cast_fptr_to_obj = Function + +instance () => Castable (Function t) (Ptr (RawFunction t)) where + cast x f = f (castPtr (get_fptr x)) + uncast x f = f (cast_fptr_to_obj (castPtr x)) + + +instance () => Castable (FunPtr t) (FunPtr t) where + cast x f = f x + uncast x f = f x + + +class () => FunPtrWrapper t where + wrapFunPtr :: t -> IO (FunPtr t) diff --git a/src/FFICXX/Runtime/TH.hs b/src/FFICXX/Runtime/TH.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Runtime/TH.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} + +module FFICXX.Runtime.TH where + +import Language.Haskell.TH ( forImpD, safe, varE ) +import Language.Haskell.TH.Syntax ( Body(NormalB), Callconv(CCall) + , Clause(..), Cxt, Dec(..) + , Exp(..), Pat(..), Q, Type(..) + , addTopDecls, mkNameS, newName + ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName, Namespace) + + +-- | Primitive C type like int, double should be treated differently than +-- Non-primitive type. The primitive type detection is not yet automatic. +-- So we manually mark template instantiation with this boolean parameter. +data IsCPrimitive = + CPrim + | NonCPrim + deriving Show + + +-- | template parameter: A,B,.. in T +data TemplateParamInfo = + TPInfo { + tpinfoCxxType :: String + -- , tpinfoIsCPrimitive :: IsCPrimitive -- ^ whether the parameter is C-primitive type + , tpinfoCxxHeaders :: [HeaderName] + , tpinfoCxxNamespaces :: [Namespace] + , tpinfoSuffix :: String + } + deriving Show + +-- | function pointer parameter A(B,C,..) in std::function +data FunctionParamInfo = + FPInfo { + fpinfoCxxArgTypes :: [(String,String)] + , fpinfoCxxRetType :: Maybe String + , fpinfoCxxHeaders :: [HeaderName] + , fpinfoCxxNamespaces :: [Namespace] + , fpinfoSuffix :: String + } + deriving Show + +con :: String -> Type +con = ConT . mkNameS + +-- | +mkInstance :: Cxt -> Type -> [Dec] -> Dec +mkInstance = InstanceD Nothing + +-- | +mkTFunc :: (types, String, String -> String, types -> Q Type) -> Q Exp +mkTFunc (typs, suffix, nf, tyf) + = do let fn = nf suffix + let fn' = "c_" <> fn + n <- newName fn' + d <- forImpD CCall safe fn n (tyf typs) + addTopDecls [d] + [| $( varE n ) |] + +-- | +mkMember :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec +mkMember fname f typ suffix = do + let x = mkNameS "x" + e <- f typ suffix + pure $ + FunD (mkNameS fname) [ Clause [VarP x] (NormalB (AppE e (VarE x))) [] ] + +-- | +mkNew :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec +mkNew fname f typ suffix = do + e <- f typ suffix + pure $ + FunD (mkNameS fname) + [ Clause [] (NormalB e) [] ] + +-- | +mkDelete :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec +mkDelete = mkMember + +-- | utility function for converting '.' to '_' +dot2_ :: String -> String +dot2_ = map (\c -> if c == '.' then '_' else c)