fficxx-runtime 0.5 → 0.6

raw patch · 13 files changed

+988/−511 lines, 13 filesdep +hashablesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Setup.lhs +0/−10
• csrc/MacroPatternMatch.h +35/−17
• fficxx-runtime.cabal +16/−13
• lib/FFICXX/Runtime/Cast.hs +0/−324
• lib/FFICXX/Runtime/Function/TH.hs +0/−55
• lib/FFICXX/Runtime/Function/Template.hs +0/−33
• lib/FFICXX/Runtime/TH.hs +0/−58
• src/FFICXX/Runtime/Cast.hs +475/−0
• src/FFICXX/Runtime/CodeGen/Cxx.hs +249/−0
• src/FFICXX/Runtime/Function/TH.hs +90/−0
• src/FFICXX/Runtime/Function/Template.hs +37/−0
• src/FFICXX/Runtime/TH.hs +85/−0

@@ -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:

@@ -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->   --  } 

@@ -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<class ToType, class FromType>-const ToType* to_const(const FromType* x) {+const ToType* from_const_to_const(const FromType* x) {   return reinterpret_cast<const ToType*>(x); }  template<class ToType, class FromType>-ToType* to_nonconst(FromType* x) {+ToType* from_nonconst_to_nonconst(FromType* x) {   return reinterpret_cast<ToType*>(x); }  template<class ToType, class FromType>-const ToType& to_constref(const FromType& x) {+ToType* from_const_to_nonconst(const FromType* x) {+  return reinterpret_cast<ToType*>(const_cast<FromType*>(x));+}++template<class ToType, class FromType>+const ToType* from_nonconst_to_const(FromType* x) {+  return const_cast<const ToType*>(reinterpret_cast<ToType*>(x));+}++template<class ToType, class FromType>+const ToType& from_constref_to_constref(const FromType& x) {   return reinterpret_cast<const ToType&>(x); }  template<class ToType, class FromType>-ToType& to_nonconstref(FromType& x) {+ToType& from_nonconstref_to_nonconstref(FromType& x) {   return reinterpret_cast<ToType&>(x); } +template<class ToType, class FromType>+ToType& from_constref_to_nonconstref(const FromType& x) {+  return reinterpret_cast<ToType&>(x);+} -#endif // __MACROPATTERNMATCH__ +template<class ToType, class FromType>+ToType& from_nonconstref_to_constref(FromType& x) {+  return const_cast<const ToType&>(reinterpret_cast<ToType&>(x));+} ++#endif // __MACROPATTERNMATCH__

@@ -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 <ianwookim@gmail.com>-Build-Type: 	Simple+License-file:   LICENSE+Author:         Ian-Woo Kim+Maintainer:     Ian-Woo Kim <ianwookim@gmail.com>+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

@@ -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 <ianwookim@gmail.com>--- 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 -

@@ -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]-              ]

@@ -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)

@@ -1,58 +0,0 @@-{-# 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 :: (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

@@ -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

@@ -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<t1,t2,..>+      (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<T1,T2,..>(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<T1,T2,..>(a1,a2,..)+  | CTNewI (CName f) (CName f) [CType f] [CExp f] -- ^ new operator for inner class of template class: new Cstr<T1,T2,..>::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 <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 "<header>"+  | 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"

@@ -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]+              ]

@@ -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)

@@ -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<A,B..>+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<A(B,C,..)>+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)