diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 (#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::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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-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: diff --git a/fficxx-runtime.cabal b/fficxx-runtime.cabal --- a/fficxx-runtime.cabal +++ b/fficxx-runtime.cabal @@ -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 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 diff --git a/src/FFICXX/Runtime/Cast.hs b/src/FFICXX/Runtime/Cast.hs --- a/src/FFICXX/Runtime/Cast.hs +++ b/src/FFICXX/Runtime/Cast.hs @@ -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 diff --git a/src/FFICXX/Runtime/CodeGen/Cxx.hs b/src/FFICXX/Runtime/CodeGen/Cxx.hs --- a/src/FFICXX/Runtime/CodeGen/Cxx.hs +++ b/src/FFICXX/Runtime/CodeGen/Cxx.hs @@ -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 - (CName f) -- ^ template type name - [ CType f ] -- ^ template parameters + | CTTApp -- template type T + (CName f) + -- ^ template type name + [CType f] + -- ^ template parameters | CTConst (CType f) | CTScoped (CType f) (CType f) -- some_class::inner_class - -- TODO: refine this by restriction + -- 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(a1,a2,..) - | CBinOp COp (CExp f) (CExp f) -- ^ binary operator: x `op` y - | CCast (CType f) (CExp f) -- ^ (type)exp - | CAddr (CExp f) -- ^ &(exp) - | CStar (CExp f) -- ^ *(exp) - | CNew (CName f) [CExp f] -- ^ new operator: new Cstr(a1,a2,...) - | CTNew (CName f) [CType f] [CExp f] -- ^ new operator for template class: new Cstr(a1,a2,..) - | CTNewI (CName f) (CName f) [CType f] [CExp f] -- ^ new operator for inner class of template class: new Cstr::inner(a1,a2,..) -- TODO: make a generalization - | CEMacroApp (CName f) [CName f] -- ^ macro function at expression level - | CEVerbatim String -- ^ verbatim - | CNull -- ^ empty C expression. (for convenience) +data CExp (f :: Type -> Type) + = -- | variable + CVar (CName f) + | -- | C function app: f(a1,a2,..) + CApp (CExp f) [CExp f] + | -- | template app : f(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(a1,a2,..) + CTNew (CName f) [CType f] [CExp f] + | -- | new operator for inner class of template class: new Cstr::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 ; - | 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 ; + 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 "
" - | 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 "
" + 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" diff --git a/src/FFICXX/Runtime/Function/TH.hs b/src/FFICXX/Runtime/Function/TH.hs --- a/src/FFICXX/Runtime/Function/TH.hs +++ b/src/FFICXX/Runtime/Function/TH.hs @@ -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] + ] diff --git a/src/FFICXX/Runtime/Function/Template.hs b/src/FFICXX/Runtime/Function/Template.hs --- a/src/FFICXX/Runtime/Function/Template.hs +++ b/src/FFICXX/Runtime/Function/Template.hs @@ -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) diff --git a/src/FFICXX/Runtime/TH.hs b/src/FFICXX/Runtime/TH.hs --- a/src/FFICXX/Runtime/TH.hs +++ b/src/FFICXX/Runtime/TH.hs @@ -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 -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 -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