packages feed

inline-c-cpp 0.4.0.3 → 0.5.0.0

raw patch · 8 files changed

+437/−212 lines, 8 filesdep +bytestringdep +text

Dependencies added: bytestring, text

Files

cxx-src/HaskellException.cxx view
@@ -28,7 +28,16 @@ { } +#ifdef	__APPLE__+HaskellException::~HaskellException() _NOEXCEPT+{+  haskellExceptionStablePtr.reset();+}++const char* HaskellException::what() const _NOEXCEPT {+#else const char* HaskellException::what() const noexcept {+#endif   return displayExceptionValue.c_str(); } @@ -45,25 +54,18 @@ } #endif -void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__){-#if defined(__GNUC__) || defined(__clang__)-  const char* demangle_result = currentExceptionTypeName();-  std::string message = "Exception: " + std::string(e.what()) + "; type: " + std::string(demangle_result);-#else-  std::string message = "Exception: " + std::string(e.what()) + "; type: not available (please use g++ or clang)";-#endif-  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);+void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typStrPtr){+  *msgStrPtr = strdup(e.what());+  setCppExceptionType(typStrPtr); } -void setMessageOfOtherException(char** __inline_c_cpp_error_message__){+void setCppExceptionType(char** typStrPtr){ #if defined(__GNUC__) || defined(__clang__)   const char* message = currentExceptionTypeName();   size_t message_len = strlen(message) + 1;-  *__inline_c_cpp_error_message__ = static_cast<char*>(std::malloc(message_len));-  std::memcpy(*__inline_c_cpp_error_message__, message, message_len);+  *typStrPtr = static_cast<char*>(std::malloc(message_len));+  std::memcpy(*typStrPtr, message, message_len); #else-  *__inline_c_cpp_error_message__ = NULL;+  *typStrPtr = NULL; #endif }
include/HaskellException.hxx view
@@ -16,16 +16,25 @@    not know in advance where and how often the exception will be copied, or when    it is released.  */+#ifdef	__APPLE__ class HaskellException : public std::exception {+#else+class HaskellException : public std::exception {+#endif public:   std::shared_ptr<HaskellStablePtr> haskellExceptionStablePtr;   std::string displayExceptionValue;    HaskellException(std::string displayExceptionValue, void *haskellExceptionStablePtr);   HaskellException(const HaskellException &);+#ifdef	__APPLE__+  virtual const char* what() const _NOEXCEPT override;+  virtual ~HaskellException() _NOEXCEPT;+#else   virtual const char* what() const noexcept override;+#endif  }; -void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__);-void setMessageOfOtherException(char** __inline_c_cpp_error_message__);+void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typeStrPtr);+void setCppExceptionType(char** typeStrPtr);
inline-c-cpp.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                inline-c-cpp-version:             0.4.0.3+version:             0.5.0.0 synopsis:            Lets you embed C++ code into Haskell. description:         Utilities to inline C++ code into Haskell using inline-c.  See                      tests for example on how to build.@@ -60,10 +60,13 @@ library   import:              cxx-opts   exposed-modules:     Language.C.Inline.Cpp+                       Language.C.Inline.Cpp.Exception                        Language.C.Inline.Cpp.Exceptions   build-depends:       base >=4.7 && <5+                     , bytestring                      , inline-c >= 0.9.0.0                      , template-haskell+                     , text                      , safe-exceptions                      , containers   hs-source-dirs:      src@@ -80,7 +83,9 @@   hs-source-dirs:      test   main-is:             tests.hs   other-modules:       StdVector+                     , TemplateSpec   build-depends:       base >=4 && <5+                     , bytestring                      , inline-c                      , inline-c-cpp                      , safe-exceptions@@ -89,7 +94,7 @@                      , template-haskell                      , vector   default-language:    Haskell2010-  cxx-options:         -Werror+  cxx-options:         -Werror -std=c++11    if impl(ghc >= 8.10)     ghc-options:
src/Language/C/Inline/Cpp.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | Module exposing a 'Context' to inline C++ code.  We only have used -- this for experiments, so use with caution.  See the C++ tests to see -- how to build inline C++ code.@@ -6,6 +10,7 @@   , cppCtx   , cppTypePairs   , using+  , AbstractCppExceptionPtr   ) where  import           Data.Monoid ((<>), mempty)@@ -27,7 +32,11 @@   { ctxForeignSrcLang = Just TH.LangCxx   , ctxOutput = Just $ \s -> "extern \"C\" {\n" ++ s ++ "\n}"   , ctxEnableCpp = True+  , ctxTypesTable = Map.singleton (CT.TypeName "std::exception_ptr") [t|AbstractCppExceptionPtr|]   }++-- | Marks an @std::exception_ptr@. Only used via 'Ptr'.+data AbstractCppExceptionPtr  -- | Emits an @using@ directive, e.g. --
+ src/Language/C/Inline/Cpp/Exception.hs view
@@ -0,0 +1,239 @@+-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters.++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.C.Inline.Cpp.Exception+  ( CppException(..)+  , CppExceptionPtr+  , toSomeException+  , throwBlock+  , tryBlock+  , catchBlock+  ) where++import           Control.Exception.Safe+import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString)+import           Data.ByteString (ByteString)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Language.C.Inline as C+import qualified Language.C.Inline.Internal as C+import qualified Language.C.Inline.Cpp as Cpp+import           Language.C.Inline.Cpp (AbstractCppExceptionPtr)+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Foreign+import           Foreign.C+import           System.IO.Unsafe(unsafePerformIO)++C.context Cpp.cppCtx+C.include "HaskellException.hxx"++-- | An exception thrown in C++ code.+data CppException+  = CppStdException CppExceptionPtr ByteString (Maybe ByteString)+  | CppHaskellException SomeException+  | CppNonStdException CppExceptionPtr (Maybe ByteString)++instance Show CppException where+  showsPrec p (CppStdException _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showsPrec 11 typ)+  showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e)+  showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ)++instance Exception CppException where+  displayException (CppStdException _ msg _typ) = bsToChars msg+  displayException (CppHaskellException e) = displayException e+  displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ+  displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type"++type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr++unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr+unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p++finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr+{-# NOINLINE finalizeAbstractCppExceptionPtr #-}+finalizeAbstractCppExceptionPtr =+  unsafePerformIO+    [C.exp|+      void (*)(std::exception_ptr *) {+        [](std::exception_ptr *v){ delete v; }+      }|]++-- | Like 'toException' but unwrap 'CppHaskellException'+toSomeException :: CppException -> SomeException+toSomeException (CppHaskellException e) = e+toSomeException x = toException x++-- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future.+pattern ExTypeNoException :: CInt+pattern ExTypeNoException = 0++pattern ExTypeStdException :: CInt+pattern ExTypeStdException = 1++pattern ExTypeHaskellException :: CInt+pattern ExTypeHaskellException = 2++pattern ExTypeOtherException :: CInt+pattern ExTypeOtherException = 3+++handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)+handleForeignCatch cont =+  alloca $ \exTypePtr ->+  alloca $ \msgCStringPtr ->+  alloca $ \typCStringPtr ->+  alloca $ \exPtr ->+  alloca $ \haskellExPtrPtr -> do+    poke exTypePtr ExTypeNoException+    -- we need to mask this entire block because the C++ allocates the+    -- string for the exception message and we need to make sure that+    -- we free it (see the @free@ below). The foreign code would not be+    -- preemptable anyway, so I do not think this loses us anything.+    mask_ $ do+      res <- cont exTypePtr msgCStringPtr typCStringPtr exPtr haskellExPtrPtr+      exType <- peek exTypePtr+      case exType of+        ExTypeNoException -> return (Right res)+        ExTypeStdException -> do+          ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr+          errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr+          mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr+          return (Left (CppStdException ex errMsg mbExcType))+        ExTypeHaskellException -> do+          haskellExPtr <- peek haskellExPtrPtr+          stablePtr <- [C.block| void * {+              return (static_cast<HaskellException *>($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr;+            } |]+          someExc <- deRefStablePtr (castPtrToStablePtr stablePtr)+          [C.block| void{+              delete static_cast<HaskellException *>($(void *haskellExPtr));+            } |]+          return (Left (CppHaskellException someExc))+        ExTypeOtherException -> do+          ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr+          mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr+          return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a)+        _ -> error "Unexpected C++ exception type."++-- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning+-- them in an 'Either'+throwBlock :: QuasiQuoter+throwBlock = QuasiQuoter+  { quoteExp = \blockStr -> do+      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]+  , quotePat = unsupported+  , quoteType = unsupported+  , quoteDec = unsupported+  } where+      unsupported _ = fail "Unsupported quasiquotation."++-- | Variant of 'throwBlock' for blocks which return 'void'.+catchBlock :: QuasiQuoter+catchBlock = QuasiQuoter+  { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}")+  , quotePat = unsupported+  , quoteType = unsupported+  , quoteDec = unsupported+  } where+      unsupported _ = fail "Unsupported quasiquotation."++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+  let (ty, body) = C.splitTypedC blockStr+  _ <- C.include "HaskellException.hxx"+  typePtrVarName <- newName "exTypePtr"+  msgPtrVarName <- newName "msgPtr"+  haskellExPtrVarName <- newName "haskellExPtr"+  exPtrVarName <- newName "exPtr"+  typeStrPtrVarName <- newName "typeStrPtr"+  let inlineCStr = unlines+        [ ty ++ " {"+        , "  int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");"+        , "  char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");"+        , "  char** __inline_c_cpp_error_typ__ = $(char** " ++ nameBase typeStrPtrVarName ++ ");"+        , "  HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " ++ nameBase haskellExPtrVarName ++ "));"+        , "  std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)$(std::exception_ptr** " ++ nameBase exPtrVarName ++ ");"+        , "  try {"+        , body+        , "  } catch (const HaskellException &e) {"+        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";"+        , "    *__inline_c_cpp_haskellexception__ = new HaskellException(e);"+        , "    return " ++ exceptionalValue ty ++ ";"+        , "  } catch (const std::exception &e) {"+        , "    *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());"+        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";"+        , "    setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);"+        , "    return " ++ exceptionalValue ty ++ ";"+        , "  } catch (...) {"+        , "    *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());"+        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";"+        , "    setCppExceptionType(__inline_c_cpp_error_typ__);"+        , "    return " ++ exceptionalValue ty ++ ";"+        , "  }"+        , "}"+        ]+  [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |]++-- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@.+-- Using this will automatically include @exception@, @cstring@ and @cstdlib@.+tryBlock :: QuasiQuoter+tryBlock = QuasiQuoter+  { quoteExp = tryBlockQuoteExp+  , quotePat = unsupported+  , quoteType = unsupported+  , quoteDec = unsupported+  } where+      unsupported _ = fail "Unsupported quasiquotation."++bsToChars :: ByteString -> String+bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
src/Language/C/Inline/Cpp/Exceptions.hs view
@@ -1,201 +1,36 @@--- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters.--{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuasiQuotes #-}--module Language.C.Inline.Cpp.Exceptions-  ( CppException(..)+{-# LANGUAGE ViewPatterns #-}+module Language.C.Inline.Cpp.Exceptions {-# DEPRECATED "Language.C.Inline.Cpp.Exceptions is deprecated in favor of Language.C.Inline.Cpp.Exception which changes the CppException data type to preserve the exception for custom error handling." #-} (+    CppException(CppHaskellException)+  , pattern Language.C.Inline.Cpp.Exceptions.CppStdException+  , pattern Language.C.Inline.Cpp.Exceptions.CppOtherException   , toSomeException   , throwBlock   , tryBlock   , catchBlock   ) where -import           Control.Exception.Safe-import qualified Language.C.Inline as C-import qualified Language.C.Inline.Internal as C-import qualified Language.C.Inline.Cpp as Cpp-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Foreign-import           Foreign.C -C.context Cpp.cppCtx-C.include "HaskellException.hxx"---- | An exception thrown in C++ code.-data CppException-  = CppStdException String-  | CppOtherException (Maybe String) -- contains the exception type, if available.-  | CppHaskellException SomeException-  deriving (Show)---- | Like 'toException' but unwrap 'CppHaskellException'-toSomeException :: CppException -> SomeException-toSomeException (CppHaskellException e) = e-toSomeException x = toException x--instance Exception CppException---- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future.-pattern ExTypeNoException :: CInt-pattern ExTypeNoException = 0--pattern ExTypeStdException :: CInt-pattern ExTypeStdException = 1--pattern ExTypeHaskellException :: CInt-pattern ExTypeHaskellException = 2--pattern ExTypeOtherException :: CInt-pattern ExTypeOtherException = 3+import           Data.ByteString (ByteString)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text as T+import           Language.C.Inline.Cpp.Exception -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)-handleForeignCatch cont =-  alloca $ \exTypePtr ->-  alloca $ \msgPtrPtr ->-  alloca $ \haskellExPtrPtr -> do-    poke exTypePtr ExTypeNoException-    -- we need to mask this entire block because the C++ allocates the-    -- string for the exception message and we need to make sure that-    -- we free it (see the @free@ below). The foreign code would not be-    -- preemptable anyway, so I do not think this loses us anything.-    mask_ $ do-      res <- cont exTypePtr msgPtrPtr haskellExPtrPtr-      exType <- peek exTypePtr-      case exType of-        ExTypeNoException -> return (Right res)-        ExTypeStdException -> do-          msgPtr <- peek msgPtrPtr-          errMsg <- peekCString msgPtr-          free msgPtr-          return (Left (CppStdException errMsg))-        ExTypeHaskellException -> do-          haskellExPtr <- peek haskellExPtrPtr-          stablePtr <- [C.block| void * {-              return (static_cast<HaskellException *>($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr;-            } |]-          someExc <- deRefStablePtr (castPtrToStablePtr stablePtr)-          [C.block| void{-              delete static_cast<HaskellException *>($(void *haskellExPtr));-            } |]-          return (Left (CppHaskellException someExc))-        ExTypeOtherException -> do-          msgPtr <- peek msgPtrPtr-          mbExcType <- if msgPtr == nullPtr-            then return Nothing-            else do-              excType <- peekCString msgPtr-              free msgPtr-              return (Just excType)-          return (Left (CppOtherException mbExcType))-        _ -> error "Unexpected C++ exception type."+bsToChars :: ByteString -> String+bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode --- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning--- them in an 'Either'-throwBlock :: QuasiQuoter-throwBlock = QuasiQuoter-  { quoteExp = \blockStr -> do-      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]-  , quotePat = unsupported-  , quoteType = unsupported-  , quoteDec = unsupported-  } where-      unsupported _ = fail "Unsupported quasiquotation."+cppStdExceptionMessage :: CppException -> Maybe String+cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t+cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)"+cppStdExceptionMessage _ = Nothing --- | Variant of 'throwBlock' for blocks which return 'void'.-catchBlock :: QuasiQuoter-catchBlock = QuasiQuoter-  { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}")-  , quotePat = unsupported-  , quoteType = unsupported-  , quoteDec = unsupported-  } where-      unsupported _ = fail "Unsupported quasiquotation."+cppNonStdExceptionType :: CppException -> Maybe (Maybe String)+cppNonStdExceptionType (CppNonStdException _ mt) = Just (fmap bsToChars mt)+cppNonStdExceptionType _ = Nothing -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"-    _ -> "{}"+pattern CppStdException :: String -> CppException+pattern CppStdException s <- (cppStdExceptionMessage -> Just s) -tryBlockQuoteExp :: String -> Q Exp-tryBlockQuoteExp blockStr = do-  let (ty, body) = C.splitTypedC blockStr-  _ <- C.include "HaskellException.hxx"-  typePtrVarName <- newName "exTypePtr"-  msgPtrVarName <- newName "msgPtr"-  haskellExPtrVarName <- newName "haskellExPtr"-  let inlineCStr = unlines-        [ ty ++ " {"-        , "  int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");"-        , "  char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");"-        , "  HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " ++ nameBase haskellExPtrVarName ++ "));"-        , "  try {"-        , body-        , "  } catch (HaskellException &e) {"-        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";"-        , "    *__inline_c_cpp_haskellexception__ = new HaskellException(e);"-        , "    return " ++ exceptionalValue ty ++ ";"-        , "  } catch (std::exception &e) {"-        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";"-        , "    setMessageOfStdException(e,__inline_c_cpp_error_message__);"-        , "    return " ++ exceptionalValue ty ++ ";"-        , "  } catch (...) {"-        , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";"-        , "    setMessageOfOtherException(__inline_c_cpp_error_message__);"-        , "    return " ++ exceptionalValue ty ++ ";"-        , "  }"-        , "}"-        ]-  [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |]- --- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@.--- Using this will automatically include @exception@, @cstring@ and @cstdlib@.-tryBlock :: QuasiQuoter-tryBlock = QuasiQuoter-  { quoteExp = tryBlockQuoteExp-  , quotePat = unsupported-  , quoteType = unsupported-  , quoteDec = unsupported-  } where-      unsupported _ = fail "Unsupported quasiquotation."+pattern CppOtherException :: Maybe String -> CppException+pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt)
+ test/TemplateSpec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module TemplateSpec where++import qualified Language.C.Inline.Cpp as C+import qualified Language.C.Inline.Context as CC+import qualified Language.C.Types as CT+import           Foreign+import           Foreign.C+import           Data.Monoid++data CppVector a++C.context $+  C.cppCtx+  <>+    C.cppTypePairs [+        ("std::vector" :: CT.CIdentifier, [t|CppVector|])+     ]++C.include "<cstdlib>"+C.include "<vector>"++-- compiles: we can return std::vector<int>*+returns_vec_of_int = do+  [C.block| std::vector<int>* {+                return ( (std::vector<int>*) NULL);+            }+  |] :: IO (Ptr (CppVector CInt))++-- compiles: we can return std::vector<signed>*+returns_vec_of_signed = do+  [C.block| std::vector<signed>* {+                return ( (std::vector<signed>*) NULL);+            }+  |] :: IO (Ptr (CppVector CInt))++-- compiles: we can return std::vector<unsigned>*+returns_vec_of_unsigned = do+  [C.block| std::vector<unsigned>* {+                return ( (std::vector<unsigned>*) NULL);+            }+  |] :: IO (Ptr (CppVector CUInt))++-- compiles: we can return std::vector<long int>*+returns_vec_of_long_int = do+  [C.block| std::vector<long int>* {+                return ( (std::vector<long int>*) NULL);+            }+  |] :: IO (Ptr (CppVector CLong))++-- compiles: we can return std::vector<short>*+returns_vec_of_short = do+  [C.block| std::vector<short>* {+                return ( (std::vector<short>*) NULL);+            }+  |] :: IO (Ptr (CppVector CShort))++-- compiles: we can return std::vector<short int>*+returns_vec_of_short_int = do+  [C.block| std::vector<short int>* {+                return ( (std::vector<short int>*) NULL);+            }+  |] :: IO (Ptr (CppVector CShort))++-- compiles: we can return std::vector<unsigned int>*+returns_vec_of_unsigned_int = do+  [C.block| std::vector<unsigned int>* {+                return ( (std::vector<unsigned int>*) NULL);+            }+  |] :: IO (Ptr (CppVector CUInt))++-- compiles: we can return long*+returns_ptr_to_long = do+  [C.block| long* {+                return ( (long*) NULL);+            }+  |] :: IO (Ptr CLong)++-- compiles: we can return unsigned long*+returns_ptr_to_unsigned_long = do+  [C.block| unsigned long* {+                return ( (unsigned long*) NULL);+            }+  |] :: IO (Ptr CULong)++-- compiles: we can return std::vector<long>*+returns_vec_of_long = do+  [C.block| std::vector<long>* {+                return ( (std::vector<long>*) NULL);+            }+  |] :: IO (Ptr (CppVector CLong))++-- compiles: we can return std::vector<long long>*+returns_vec_of_long_long = do+  [C.block| std::vector<long long>* {+                return ( (std::vector<long long>*) NULL);+            }+  |] :: IO (Ptr (CppVector CLLong))+
test/tests.hs view
@@ -17,13 +17,17 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-deprecations #-}  import           Control.Exception.Safe import           Control.Monad+import qualified Data.ByteString as BS+import           Data.ByteString (ByteString) 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 Language.C.Inline.Cpp.Exception as C+import qualified Language.C.Inline.Cpp.Exceptions as Legacy import           Foreign.C.String (withCString) import           Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) import qualified Test.Hspec as Hspec@@ -34,10 +38,11 @@ import qualified StdVector import qualified Data.Vector.Storable as VS + data Test data Array a -C.context $ C.cppCtx `mappend` C.cppTypePairs [+C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [   ("Test::Test", [t|Test|]),   ("std::array", [t|Array|])   ] `mappend` StdVector.stdVectorCtx@@ -121,7 +126,24 @@         |]        case result of-        Left (C.CppOtherException (Just ty)) | "string" `isInfixOf` ty -> return ()+        Left (C.CppNonStdException ex (Just ty)) -> do+          ("string" `BS.isInfixOf` ty) `shouldBe` True+          [C.throwBlock| int {+            std::exception_ptr *e = $fptr-ptr:(std::exception_ptr *ex);+            if (!e) throw std::runtime_error("Exception was null");+            try {+              std::cerr << "throwing..." << std::endl;+              std::rethrow_exception(*e);+            } catch (std::string &foobar) {+              if (foobar == "FOOBAR")+                return 42;+              else+                return 1;+            } catch (...) {+              return 2;+            }+            return 3;+          }|] >>= \r -> r `shouldBe` 42         _ -> error ("Expected Left CppOtherException with string type, but got " ++ show result)      Hspec.it "catch without return (pure)" $ do@@ -268,21 +290,23 @@         *a = 100;         $(std::vector<int*>* pt)->push_back(a);         std::cout << *((*$(std::vector<int*>* pt))[0]) << std::endl;+        delete a;+        delete $(std::vector<int*>* pt);       } |]  tag :: C.CppException -> String tag (C.CppStdException {}) = "CppStdException" tag (C.CppHaskellException {}) = "CppHaskellException"-tag (C.CppOtherException {}) = "CppStdException"+tag (Legacy.CppOtherException {}) = "CppStdException"  shouldBeCppStdException :: Either C.CppException a -> String -> IO ()-shouldBeCppStdException (Left (C.CppStdException actualMsg)) expectedMsg = do+shouldBeCppStdException (Left (Legacy.CppStdException actualMsg)) expectedMsg = do   actualMsg `Hspec.shouldBe` expectedMsg shouldBeCppStdException (Left x) expectedMsg = tag x `Hspec.shouldBe` ("CppStdException " <> show expectedMsg) shouldBeCppStdException (Right _) expectedMsg = "Right _" `Hspec.shouldBe` ("Left (CppStdException " <> show expectedMsg <> ")")  shouldBeCppOtherException :: Either C.CppException a -> Maybe String -> IO ()-shouldBeCppOtherException (Left (C.CppOtherException actualType)) expectedType = do+shouldBeCppOtherException (Left (Legacy.CppOtherException actualType)) expectedType = do   actualType `Hspec.shouldBe` expectedType shouldBeCppOtherException (Left x) expectedType = tag x `Hspec.shouldBe` ("CppOtherException " <> show expectedType) shouldBeCppOtherException (Right _) expectedType = "Right _" `Hspec.shouldBe` ("Left (CppOtherException " <> show expectedType <> ")")