fficxx-runtime 0.6 → 0.7.0.0

raw patch · 8 files changed

+735/−375 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +62/−0
• LICENSE +1/−1
• fficxx-runtime.cabal +9/−6
• src/FFICXX/Runtime/Cast.hs +289/−71
• src/FFICXX/Runtime/CodeGen/Cxx.hs +210/−168
• src/FFICXX/Runtime/Function/TH.hs +95/−77
• src/FFICXX/Runtime/Function/Template.hs +16/−14
• src/FFICXX/Runtime/TH.hs +53/−38

@@ -0,0 +1,62 @@+# Changelog for fficxx-runtime++## 0.7.0.0++- Show generated module dependency graph (#203)+- Fix incorrect hs-boot (#199)+- Simplify Nix script and support for multiple GHC versions in build (#196)+- aarch64-darwin support (#195)+- Implicit imports cleanup (#193)+- Upgrade to NixOS 21.11. (#192)+- CI action for ormolu formatting (#190)+- github action CI with nix build targets (#189)+- format all Haskell files by ormolu 0.0.3 (#180)+++## 0.6++- no more impure <nixpkgs> (#178)+- Duplicated template instances are safe (#176)+- Update for haskell-src-exts >= 1.22 (#174)+- change to_const/to_nonconst to from_X_to_Y (#172)+- std::map<k,v>::iterator is now supported. (#168)+- accessor for member variables of C++ template (#167)+- Support nested types inside template class (#163)+- Automatic dependency import in template class module (#162)+- cabal package generation and testing using hspec (#159)+- fficxx-test: stdcxx tests are rewritten as hspec tests (#158)+- multi-parameter template for function arguments and template member functions (#156)+- C++ multi-parameter template interfaced via fficxx! (#154)+- one class or template class per one haskell module! (#151)+- Inline C++ code generation for template member function (#149)+- Inline C++ code generation for std::function (#148)+- CDefinition. Unified newline treatment in Macro definition (#143)+- More ASTification with CMacroApp (#141)+- Declaration generation uses intermediate pseudo-AST representation (#140)+- Further towards intermediate reps for C++ code generation (#139)+- Further removing #include and using namespace (#138)+- Start C intermediate rep (#137)+- Convert (Types,String) to Arg (#134)+- no more stub.cc (#132)++## 0.5.1++## 0.5.0.1++## 0.5++## 0.4.1++## 0.4++## 0.3.1++## 0.3++## 0.2.1++## 0.2++## 0.1.0++## 0.1

@@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2019, Ian-Woo Kim. All rights reserved.+Copyright 2011-2022, 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,16 +1,18 @@+Cabal-Version:  3.0 Name:           fficxx-runtime-Version:        0.6+Version:        0.7.0.0 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:        BSD-2-Clause License-file:   LICENSE Author:         Ian-Woo Kim Maintainer:     Ian-Woo Kim <ianwookim@gmail.com> Build-Type:     Simple+Tested-With:    GHC == 9.0.2 || == 9.2.4 || == 9.4.2 Category:       FFI Tools-Cabal-Version:  >= 1.10-Data-files:+Extra-Source-Files:+  ChangeLog.md  Source-repository head   type: git@@ -19,13 +21,11 @@ Library   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.CodeGen.Cxx@@ -38,3 +38,6 @@   Install-includes: MacroPatternMatch.h                     Function.h                     cpp_magic.h+  ghc-options: -Wall+               -funbox-strict-fields+               -fno-warn-unused-do-bind

@@ -10,75 +10,140 @@  module FFICXX.Runtime.Cast where -import Data.ByteString.Char8 (ByteString,packCString, useAsCString)-import Data.Word-import Data.Int+import Data.ByteString.Char8 (ByteString, packCString, useAsCString)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Kind (Type)+import Data.Word (Word16, Word32, Word64, Word8) import Foreign.C-import Foreign.Marshal.Array-import Foreign.Ptr-+  ( CBool,+    CChar,+    CClock,+    CDouble,+    CFile,+    CFloat,+    CFpos,+    CInt,+    CIntMax,+    CIntPtr,+    CJmpBuf,+    CLLong,+    CLong,+    CPtrdiff,+    CSChar,+    CSUSeconds,+    CShort,+    CSigAtomic,+    CSize,+    CString,+    CTime,+    CUChar,+    CUInt,+    CUIntMax,+    CUIntPtr,+    CULLong,+    CULong,+    CUSeconds,+    CUShort,+    CWchar,+  )+import Foreign.Marshal.Array (newArray, withArray)+import Foreign.Ptr (FunPtr, Ptr)  class IsRawType a  class Castable a b where-  cast   :: a -> (b -> IO r) -> IO r+  cast :: a -> (b -> IO r) -> IO r   uncast :: b -> (a -> IO r) -> IO r  class FPtr a where-  type Raw a :: *+  type Raw a :: Type   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 :: *+  type FunPtrHsType a :: Type+  type FunPtrType a :: Type+  data FunPtrWrapped a :: Type   fptrWrap :: FunPtrWrapped a -> IO (FunPtr (FunPtrType a))   wrap :: FunPtrHsType a -> FunPtrWrapped a --class IsCType a where+class IsCType a  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 IsCType Word64  instance Castable () () where   cast x f = f x@@ -264,7 +329,6 @@   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)@@ -305,8 +369,9 @@  -- 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+  cast xs f = do+    ys <- mapM (\x -> useAsCString x return) xs+    withArray ys $ \cptr -> f cptr   uncast _ _ = undefined  {-@@ -314,7 +379,6 @@   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@@ -323,33 +387,58 @@ 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 ::+  (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 ::+  (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+  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 ::+  (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+  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 ::+  (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+  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 ::+  (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 ->@@ -358,10 +447,23 @@           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 ::+  ( 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 ->@@ -371,10 +473,25 @@             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 ::+  ( 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 ->@@ -385,10 +502,27 @@               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 ::+  ( 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 ->@@ -400,11 +534,29 @@                 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 ::+  ( 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 ->@@ -417,11 +569,31 @@                   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 ::+  ( 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 ->@@ -435,11 +607,33 @@                     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 ::+  ( 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 ->@@ -454,11 +648,35 @@                       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 ::+  ( 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 ->@@ -472,4 +690,4 @@                     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+                          f ca cx1 cx2 cx3 cx4 cx5 cx6 cx7 cx8 cx9 cx10 cx11 >>= \cy -> uncast cy return

@@ -4,23 +4,19 @@ 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(..) )-+import Data.Hashable (Hashable)+import Data.Kind (Type)+import Data.List (intercalate)+import Data.String (IsString (..)) -newtype HeaderName =-  HdrName { unHdrName :: String }+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)+newtype Namespace = NS {unNamespace :: String}+  deriving (Show, Eq, Ord)  instance IsString Namespace where   fromString = NS@@ -28,9 +24,9 @@ data PragmaParam = Once  -- | parts for interpolation-newtype NamePart (f :: * -> *) = NamePart String+newtype NamePart (f :: Type -> Type) = NamePart String -newtype CName (f :: * -> *) = CName [NamePart f]+newtype CName (f :: Type -> Type) = CName [NamePart f]  sname :: String -> CName Identity sname s = CName [NamePart s]@@ -39,151 +35,195 @@ renderCName (CName ps) = intercalate "##" $ map (\(NamePart p) -> p) ps  -- | Types-data CType (f :: * -> *) =-    CTVoid+data CType (f :: Type -> Type)+  = CTVoid   | CTSimple (CName f)   | CTStar (CType f)   | CTAuto-  | CTTApp        -- template type T<t1,t2,..>-      (CName f)   -- ^ template type name-      [ CType f ] -- ^ template parameters+  | 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+  -- TODO: refine this by restriction   | CTVerbatim String  -- | Operators data COp = CArrow | CAssign  renderCOp :: COp -> String-renderCOp CArrow  = "->"+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 CExp (f :: Type -> Type)+  = -- | variable+    CVar (CName f)+  | -- | C function app:  f(a1,a2,..)+    CApp (CExp f) [CExp f]+  | -- | template app  :  f<T1,T2,..>(a1,a2,..)+    CTApp (CName f) [CType f] [CExp f]+  | -- | binary operator: x `op` y+    CBinOp COp (CExp f) (CExp f)+  | -- | (type)exp+    CCast (CType f) (CExp f)+  | -- | &(exp)+    CAddr (CExp f)+  | -- | *(exp)+    CStar (CExp f)+  | -- | new operator: new Cstr(a1,a2,...)+    CNew (CName f) [CExp f]+  | -- | new operator for template class: new Cstr<T1,T2,..>(a1,a2,..)+    CTNew (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+    CTNewI (CName f) (CName f) [CType f] [CExp f]+  | -- | macro function at expression level+    CEMacroApp (CName f) [CName f]+  | -- | verbatim+    CEVerbatim String+  | -- | empty C expression. (for convenience)+    CNull -data CFunDecl (f :: * -> *) =-  CFunDecl (CType f) (CName f) [(CType f,CName f)] -- ^ type func( type1 arg1, type2 arg2, ... )+data CFunDecl (f :: Type -> Type)+  = -- | type func( type1 arg1, type2 arg2, ... )+    CFunDecl (CType f) (CName f) [(CType f, CName f)] -data CVarDecl (f :: * -> *) =-  CVarDecl-    (CType f)  -- ^ type-    (CName f)  -- ^ variable name+data CVarDecl (f :: Type -> Type)+  = 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 CStatement (f :: Type -> Type)+  = -- | using namespace <namespace>;+    UsingNamespace Namespace+  | -- | typedef origtype newname;+    TypeDef (CType f) (CName f)+  | -- | C expression standalone;+    CExpSA (CExp f)+  | -- | function declaration;+    CDeclaration (CFunDecl f)+  | -- | function definition;+    CDefinition (Maybe CQual) (CFunDecl f) [CStatement f]+  | -- | variable initialization;+    CInit (CVarDecl f) (CExp f)+  | -- | return statement;+    CReturn (CExp f)+  | -- | delete statement;+    CDelete (CExp f)+  | -- | C Macro application at statement level (temporary)+    CMacroApp (CName f) [CName f]+  | -- | extern "C" {..}+    CExtern [CStatement f]+  | -- | comment+    Comment String+  | -- | for convenience+    CEmptyLine+  | -- | temporary verbatim+    CVerbatim String -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 CMacro (f :: Type -> Type)+  = -- | regular C++ statement+    CRegular (CStatement f)+  | -- | #include "<header>"+    Include HeaderName+  | -- | #pragma+    Pragma PragmaParam+  | -- | #undef name+    Undef (CName f)+  | -- | #define macro (type) definition+    Define (CName f) [CName f] [CStatement f]+  | -- | just for convenience+    EmptyLine+  | -- | temporary verbatim+    Verbatim String -data CBlock (f :: * -> *) = ExternC [CMacro f] -- extern "C" with #ifdef __cplusplus guard.+data CBlock (f :: Type -> Type) = 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 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           = ""+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) <> " )"+  renderCType typ <> " " <> renderCName fname <> " ( " <> intercalate ", " (map mkArgStr args) <> " )"   where     mkArgStr (t, a) = renderCType t <> " " <> renderCName a @@ -193,57 +233,59 @@ -- | 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+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 (Comment _str) = [""] -- Comment cannot exist in Macro+renderCStmtInMacro CEmptyLine = [""] renderCStmtInMacro (CVerbatim str) = lines str-renderCStmtInMacro s               = lines (renderCStmt s)+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-+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"+  "\n#ifdef __cplusplus\n\+  \extern \"C\" {\n\+  \#endif\n"+    ++ concatMap renderCMacro ms+    ++ "\n#ifdef __cplusplus\n\+       \}\n\+       \#endif\n"

@@ -1,90 +1,108 @@ {-# 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 Data.List (intercalate)+import Data.Maybe (fromMaybe) ---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)) [] ]+import FFICXX.Runtime.CodeGen.Cxx (CMacro (..), CStatement (..), renderCMacro, renderCStmt)+import FFICXX.Runtime.Function.Template (Function)+import FFICXX.Runtime.TH+  ( FunctionParamInfo (..),+    con,+    mkInstance,+    mkMember,+    mkNew,+    mkTFunc,+  )+import Foreign.Ptr (FunPtr)+import Language.Haskell.TH (forImpD, safe)+import Language.Haskell.TH.Syntax+  ( Body (NormalB),+    Callconv (CCall),+    Clause (..),+    Dec (..),+    Exp (..),+    ForeignSrcLang (LangCxx),+    Q,+    Type (..),+    addForeignSource,+    addModFinalizer,+    addTopDecls,+    mkNameS,+    newName,+  ) +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_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_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 () |]-+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]-              ]+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]+      ]

@@ -1,37 +1,39 @@-{-# LANGUAGE EmptyDataDecls        #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module FFICXX.Runtime.Function.Template where-import Foreign.Ptr-import FFICXX.Runtime.Cast +import FFICXX.Runtime.Cast+  ( Castable (..),+    FPtr (..),+    Raw (..),+  )+import Foreign.Ptr (FunPtr, Ptr, castPtr)  data RawFunction t  newtype Function t = Function (Ptr (RawFunction t)) -class () => IFunction t where+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+  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))-+  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+class FunPtrWrapper t where   wrapFunPtr :: t -> IO (FunPtr t)

@@ -2,46 +2,51 @@  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)-+import FFICXX.Runtime.CodeGen.Cxx (HeaderName, Namespace)+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,+  )  -- | 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+data IsCPrimitive+  = CPrim   | NonCPrim-  deriving Show-+  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+data TemplateParamInfo = TPInfo+  { tpinfoCxxType :: String,+    -- , tpinfoIsCPrimitive  :: IsCPrimitive  -- ^ whether the parameter is C-primitive type+    tpinfoCxxHeaders :: [HeaderName],+    tpinfoCxxNamespaces :: [Namespace],+    tpinfoSuffix :: String   }-  deriving Show+  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+data FunctionParamInfo = FPInfo+  { fpinfoCxxArgTypes :: [(String, String)],+    fpinfoCxxRetType :: Maybe String,+    fpinfoCxxHeaders :: [HeaderName],+    fpinfoCxxNamespaces :: [Namespace],+    fpinfoSuffix :: String   }-  deriving Show+  deriving (Show)  con :: String -> Type con = ConT . mkNameS@@ -52,13 +57,14 @@  -- | 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 ) |]+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@@ -66,19 +72,28 @@   let x = mkNameS "x"   e <- f typ suffix   pure $-    FunD (mkNameS fname) [ Clause [VarP x] (NormalB (AppE e (VarE x))) [] ]+    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) [] ]+    FunD+      (mkNameS fname)+      [Clause [] (NormalB e) []]  -- | mkDelete :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkDelete = mkMember++-- |+mkFunc :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec+mkFunc 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))) []]  -- | utility function for converting '.' to '_' dot2_ :: String -> String