Support identifiers for namespace/template of C++

.travis.yml

@@ -14,6 +14,7 @@ addons:
   homebrew:
     packages:
     - cairo
+    - cairocffi
     - gsl
 
 matrix:

inline-c-cpp/inline-c-cpp.cabal

@@ -24,6 +24,7 @@ library
                      , inline-c >= 0.6.1.0
                      , template-haskell
                      , safe-exceptions
+                     , containers
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall -optc-xc++ -optc-std=c++11
@@ -41,10 +42,13 @@ test-suite tests
                      , inline-c-cpp
                      , safe-exceptions
                      , hspec
+                     , containers
   default-language:    Haskell2010
   ghc-options:
     -optc-std=c++11
   if os(darwin)
     ghc-options: -pgmc=clang++
   extra-libraries:     stdc++
-  cc-options:          -Wall -Werror -optc-xc++ -std=c++11
+  cc-options:          -Wall -Werror
+  if os(darwin)
+    ld-options: -Wl,-keep_dwarf_unwind

inline-c-cpp/src/Language/C/Inline/Cpp.hs

@@ -4,6 +4,7 @@
 module Language.C.Inline.Cpp
   ( module Language.C.Inline
   , cppCtx
+  , cppTypePairs
   , using
   ) where
 
@@ -13,6 +14,9 @@ import qualified Language.Haskell.TH.Syntax as TH
 
 import           Language.C.Inline
 import           Language.C.Inline.Context
+import qualified Language.C.Types as CT
+
+import qualified Data.Map as Map
 
 -- | The equivalent of 'C.baseCtx' for C++.  It specifies the @.cpp@
 -- file extension for the C file, so that g++ will decide to build C++
@@ -31,3 +35,9 @@ cppCtx = baseCtx <> mempty
 -- @
 using :: String -> TH.DecsQ
 using s = verbatim $ "using " ++ s ++ ";"
+
+
+cppTypePairs :: [(CT.CIdentifier, TH.TypeQ)] -> Context
+cppTypePairs typePairs =  mempty {
+  ctxTypesTable = Map.fromList $ map (\(cpp_sym, haskell_sym) -> (CT.TypeName cpp_sym, haskell_sym)) typePairs
+  }

inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs

@@ -87,7 +87,85 @@ catchBlock = QuasiQuoter
   , quoteDec = unsupported
   } where
       unsupported _ = fail "Unsupported quasiquotation."
-
+
+
+
+{-
+
+Some compilers can not parse "{}" as generalized initializer.(See following the example of test.cpp.)
+"exceptionalValue"-function assigns initial value for numeric types.
+Many numeric types can be initialized with 0.
+
+-- test.cpp --
+int
+test(){
+  try {
+    throw  "Exception\n";
+  }catch(...) {
+    return {};
+  }
+}
+
+---In case of clang -----------
+$ clang++ -c test.cpp
+test.cpp:6:12: warning: generalized initializer lists are a C++11 extension [-Wc++11-extensions]
+    return {};
+           ^~
+test.cpp:6:12: error: scalar initializer cannot be empty
+    return {};
+           ^~
+1 warning and 1 error generated.
+
+---In case of gcc- -----------
+$ g++ -c test.cpp
+test.cpp: In function ‘int test()’:
+test.cpp:6:12: warning: extended initializer lists only available with -std=c++11 or -std=gnu++11
+     return {};
+
+-}
+exceptionalValue :: String -> String
+exceptionalValue typeStr =
+  case typeStr of
+    "void" -> ""
+    "char" -> "0"
+    "short" -> "0"
+    "long" -> "0"
+    "int" -> "0"
+    "int8_t" -> "0"
+    "int16_t" -> "0"
+    "int32_t" -> "0"
+    "int64_t" -> "0"
+    "uint8_t" -> "0"
+    "uint16_t" -> "0"
+    "uint32_t" -> "0"
+    "uint64_t" -> "0"
+    "float" -> "0"
+    "double" -> "0"
+    "bool" -> "0"
+    "signed char" -> "0"
+    "signed short" -> "0"
+    "signed int" -> "0"
+    "signed long" -> "0"
+    "unsigned char" -> "0"
+    "unsigned short" -> "0"
+    "unsigned int" -> "0"
+    "unsigned long" -> "0"
+    "size_t" -> "0"
+    "wchar_t" -> "0"
+    "ptrdiff_t" -> "0"
+    "sig_atomic_t" -> "0"
+    "intptr_t" -> "0"
+    "uintptr_t" -> "0"
+    "intmax_t" -> "0"
+    "uintmax_t" -> "0"
+    "clock_t" -> "0"
+    "time_t" -> "0"
+    "useconds_t" -> "0"
+    "suseconds_t" -> "0"
+    "FILE" -> "0"
+    "fpos_t" -> "0"
+    "jmp_buf" -> "0"
+    _ -> "{}"
 
 tryBlockQuoteExp :: String -> Q Exp
 tryBlockQuoteExp blockStr = do
@@ -130,7 +208,7 @@ tryBlockQuoteExp blockStr = do
         , "    size_t message_len = message.size() + 1;"
         , "    *__inline_c_cpp_error_message__ = static_cast<char*>(std::malloc(message_len));"
         , "    std::memcpy(*__inline_c_cpp_error_message__, message.c_str(), message_len);"
-        , if ty == "void" then "return;" else "return {};"
+        , "    return " ++ exceptionalValue ty ++ ";"
         , "  } catch (...) {"
         , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";"
         , "#if defined(__GNUC__) || defined(__clang__)"
@@ -142,7 +220,7 @@ tryBlockQuoteExp blockStr = do
         , "#else"
         , "    *__inline_c_cpp_error_message__ = NULL;"
         , "#endif"
-        , if ty == "void" then "return;" else "return {};"
+        , "    return " ++ exceptionalValue ty ++ ";"
         , "  }"
         , "}"
         ]

inline-c-cpp/test/test.h

@@ -0,0 +1,8 @@
+namespace Test {
+	class Test {
+	public:
+		Test() {}
+		int get () {return 3;}
+	};
+};
+;

inline-c-cpp/test/tests.hs

@@ -1,18 +1,36 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
 
 import           Control.Exception.Safe
 import           Control.Monad
 import qualified Language.C.Inline.Cpp as C
+import qualified Language.C.Inline.Context as CC
+import qualified Language.C.Types as CT
 import qualified Language.C.Inline.Cpp.Exceptions as C
 import qualified Test.Hspec as Hspec
+import           Foreign.Ptr (Ptr)
 import           Data.List (isInfixOf)
 
-C.context C.cppCtx
+data Test
+data Vector a
+data Array a
+
+C.context $ C.cppCtx `mappend` C.cppTypePairs [
+  ("Test::Test", [t|Test|]),
+  ("std::vector", [t|Vector|]),
+  ("std::array", [t|Array|])
+  ]
 
 C.include "<iostream>"
+C.include "<vector>"
+C.include "<array>"
+C.include "<tuple>"
 C.include "<stdexcept>"
+C.include "test.h"
 
 main :: IO ()
 main = Hspec.hspec $ do
@@ -23,6 +41,41 @@ main = Hspec.hspec $ do
           std::cout << "Hello, world!" << $(int x) << std::endl;
         } |]
 
+  Hspec.describe "C++ Types" $ do
+    Hspec.it "Hello Namespace" $ do
+      pt <- [C.block| Test::Test* {
+          return new Test::Test();
+        } |] :: IO (Ptr Test)
+      [C.block| void {
+          std::cout << $(Test::Test* pt)->get() << std::endl;
+        } |]
+
+    Hspec.it "Hello Template" $ do
+      pt <- [C.block| std::vector<int>* {
+          return new std::vector<int>();
+        } |] :: IO (Ptr (Vector C.CInt))
+      [C.block| void {
+          $(std::vector<int>* pt)->push_back(100);
+          std::cout << (*$(std::vector<int>* pt))[0] << std::endl;
+        } |]
+
+    Hspec.it "Template + Namespace" $ do
+      pt <- [C.block| std::vector<Test::Test>* {
+          return new std::vector<Test::Test>();
+        } |] :: IO (Ptr (Vector Test))
+      [C.block| void {
+          $(std::vector<Test::Test>* pt)->push_back(Test::Test());
+        } |]
+
+    Hspec.it "Template with 2 arguments" $ do
+      pt <- [C.block| std::array<int,10>* {
+          return new std::array<int,10>();
+        } |] :: IO (Ptr (Array '(C.CInt,10)))
+      [C.block| void {
+          (*$(std::array<int,10>* pt))[0]=true;
+          std::cout << (*$(std::array<int,10>* pt))[0] << std::endl;
+        } |]
+
   Hspec.describe "Exception handling" $ do
     Hspec.it "std::exceptions are caught" $ do
       result <- try [C.catchBlock|

inline-c/src/Language/C/Inline/Context.hs

@@ -1,14 +1,20 @@
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | A 'Context' is used to define the capabilities of the Template Haskell code
 -- that handles the inline C code. See the documentation of the data type for
@@ -43,7 +49,7 @@ module Language.C.Inline.Context
   ) where
 
 import           Control.Applicative ((<|>))
-import           Control.Monad (mzero)
+import           Control.Monad (mzero, forM)
 import           Control.Monad.Trans.Class (lift)
 import           Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
 import qualified Data.ByteString as BS
@@ -64,6 +70,7 @@ import qualified Language.Haskell.TH.Syntax as TH
 import qualified Text.Parser.Token as Parser
 import qualified Data.HashSet as HashSet
 
+
 #if MIN_VERSION_base(4,9,0)
 import           Data.Semigroup (Semigroup, (<>))
 #else
@@ -201,6 +208,7 @@ baseTypesTable = Map.fromList
   -- along with its documentation's section headers.
   --
   -- Integral types
+  , (C.Bool, [t| CBool |])
   , (C.Char Nothing, [t| CChar |])
   , (C.Char (Just C.Signed), [t| CSChar |])
   , (C.Char (Just C.Unsigned), [t| CUChar |])
@@ -263,7 +271,30 @@ convertType purity cTypes = runMaybeT . go
     goDecl = go . C.parameterDeclarationType
 
     go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type
-    go cTy = case cTy of
+    go cTy = do
+     case cTy of
+      C.TypeSpecifier _specs (C.CxxTemplate ident' cTys) -> do
+--        let symbol = TH.LitT (TH.StrTyLit (C.unCIdentifier ident'))
+        symbol <- case Map.lookup (C.TypeName ident') cTypes of
+          Nothing -> mzero
+          Just ty -> return ty
+        hsTy <- forM cTys $ \cTys'  -> go (C.TypeSpecifier undefined cTys')
+        case hsTy of
+          (a:[]) ->
+            lift [t| $(symbol) $(return a) |]
+          (a:b:[]) ->
+            lift [t| $(symbol) '($(return a),$(return b))|]
+          (a:b:c:[]) ->
+            lift [t| $(symbol) '($(return a),$(return b),$(return c))|]
+          (a:b:c:d:[]) ->
+            lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d))|]
+          (a:b:c:d:e:[]) ->
+            lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d),$(return e))|]
+          [] -> fail $ "Can not find template parameters."
+          _ -> fail $ "Find too many template parameters. num = " ++ show (length hsTy)
+      C.TypeSpecifier _specs (C.CxxTemplateConst num) -> do
+        let n = (TH.LitT (TH.NumTyLit (read num)))
+        lift [t| $(return n) |]
       C.TypeSpecifier _specs cSpec ->
         case Map.lookup cSpec cTypes of
           Nothing -> mzero
@@ -451,7 +482,8 @@ vecLenAntiQuoter :: AntiQuoter HaskellIdentifier
 vecLenAntiQuoter = AntiQuoter
   { aqParser = do
       hId <- C.parseIdentifier
-      let cId = mangleHaskellIdentifier hId
+      useCpp <- C.parseEnableCpp
+      let cId = mangleHaskellIdentifier useCpp hId
       return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId)
   , aqMarshaller = \_purity _cTypes cTy cId -> do
       case cTy of
@@ -486,7 +518,8 @@ bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
 bsPtrAntiQuoter = AntiQuoter
   { aqParser = do
       hId <- C.parseIdentifier
-      let cId = mangleHaskellIdentifier hId
+      useCpp <- C.parseEnableCpp
+      let cId = mangleHaskellIdentifier useCpp hId
       return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId)
   , aqMarshaller = \_purity _cTypes cTy cId -> do
       case cTy of
@@ -503,7 +536,8 @@ bsLenAntiQuoter :: AntiQuoter HaskellIdentifier
 bsLenAntiQuoter = AntiQuoter
   { aqParser = do
       hId <- C.parseIdentifier
-      let cId = mangleHaskellIdentifier hId
+      useCpp <- C.parseEnableCpp
+      let cId = mangleHaskellIdentifier useCpp hId
       return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId)
   , aqMarshaller = \_purity _cTypes cTy cId -> do
       case cTy of
@@ -521,7 +555,8 @@ bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier
 bsCStrAntiQuoter = AntiQuoter
   { aqParser = do
       hId <- C.parseIdentifier
-      let cId = mangleHaskellIdentifier hId
+      useCpp <- C.parseEnableCpp
+      let cId = mangleHaskellIdentifier useCpp hId
       return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId)
   , aqMarshaller = \_purity _cTypes cTy cId -> do
       case cTy of
@@ -543,18 +578,20 @@ cDeclAqParser
   => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier)
 cDeclAqParser = do
   cTy <- Parser.parens C.parseParameterDeclaration
+  useCpp <- C.parseEnableCpp
   case C.parameterDeclarationId cTy of
     Nothing -> fail "Every captured function must be named (funCtx)"
     Just hId -> do
-     let cId = mangleHaskellIdentifier hId
+     let cId = mangleHaskellIdentifier useCpp hId
      cTy' <- deHaskellifyCType $ C.parameterDeclarationType cTy
      return (cId, cTy', hId)
 
 deHaskellifyCType
   :: C.CParser HaskellIdentifier m
   => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier)
 deHaskellifyCType = traverse $ \hId -> do
-  case C.cIdentifierFromString (unHaskellIdentifier hId) of
+  useCpp <- C.parseEnableCpp
+  case C.cIdentifierFromString useCpp (unHaskellIdentifier hId) of
     Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId ++
                        " in C type:\n" ++ err
     Right x -> return x