inline-c-cpp 0.5.0.0 → 0.5.0.1

raw patch · 6 files changed

+158/−37 lines, 6 filesdep +system-cxx-std-libPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: system-cxx-std-lib

API changes (from Hackage documentation)

Files

• cxx-src/HaskellException.cxx +33/−7
• include/HaskellException.hxx +2/−2
• inline-c-cpp.cabal +9/−3
• src/Language/C/Inline/Cpp/Exception.hs +43/−24
• src/Language/C/Inline/Cpp/Unsafe.hs +53/−0
• test/tests.hs +18/−1

@@ -46,25 +46,51 @@ // <https://stackoverflow.com/questions/561997/determining-exception-type-after-the-exception-is-caught/47164539#47164539> // regarding how to show the type of an exception. +/* mallocs a string representing the exception type name or error condition.++   Ideally, this returns a demangled string, but it may degrade to+    - a mangled string if demangling fails,+    - "<unknown exception>" if exception type info is not available,+    - "<no exception>" if no current exception is found.++   The responsibility for freeing the returned string falls on the caller,+   such as handleForeignCatch, which passes the responsibility on to ByteString++ */ #if defined(__GNUC__) || defined(__clang__) const char* currentExceptionTypeName() {+  std::type_info *type_info = abi::__cxa_current_exception_type();+  if (!type_info)+    return strdup("<no exception>");++  const char *raw_name = type_info->name();+  if (!raw_name)+    return strdup("<unknown exception>");+   int demangle_status;-  return abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status);+  const char *demangled_name = abi::__cxa_demangle(raw_name, 0, 0, &demangle_status);+  if (!demangled_name)+    return strdup(raw_name);++  return demangled_name; } #endif -void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typStrPtr){+/* Set the message and type strings.++   The responsibility for freeing the returned string falls on the caller,+   such as handleForeignCatch, which passes the responsibility on to a+   ByteString.+ */+void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typStrPtr){   *msgStrPtr = strdup(e.what());   setCppExceptionType(typStrPtr); } -void setCppExceptionType(char** typStrPtr){+void setCppExceptionType(const char** typStrPtr){ #if defined(__GNUC__) || defined(__clang__)-  const char* message = currentExceptionTypeName();-  size_t message_len = strlen(message) + 1;-  *typStrPtr = static_cast<char*>(std::malloc(message_len));-  std::memcpy(*typStrPtr, message, message_len);+  *typStrPtr = currentExceptionTypeName(); #else   *typStrPtr = NULL; #endif

@@ -36,5 +36,5 @@  }; -void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typeStrPtr);-void setCppExceptionType(char** typeStrPtr);+void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typeStrPtr);+void setCppExceptionType(const char** typeStrPtr);

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                inline-c-cpp-version:             0.5.0.0+version:             0.5.0.1 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.@@ -37,9 +37,14 @@     -- version configured there.     -std=c++11     -Wall-  extra-libraries: stdc++ -  if os(darwin)+  -- Linking to the C++ standard library+  if impl(ghc >= 9.4)+    build-depends: system-cxx-std-lib == 1.0+  elif os(linux)+    extra-libraries: stdc+++  elif os(darwin)+    extra-libraries: c++     -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829     ld-options:  -Wl,-keep_dwarf_unwind @@ -62,6 +67,7 @@   exposed-modules:     Language.C.Inline.Cpp                        Language.C.Inline.Cpp.Exception                        Language.C.Inline.Cpp.Exceptions+                       Language.C.Inline.Cpp.Unsafe   build-depends:       base >=4.7 && <5                      , bytestring                      , inline-c >= 0.9.0.0

@@ -12,6 +12,7 @@   , throwBlock   , tryBlock   , catchBlock+  , tryBlockQuoteExp   ) where  import           Control.Exception.Safe@@ -52,8 +53,15 @@  type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr +-- | This converts a plain pointer to a managed object.+--+-- The pointer must have been created with @new@. The returned 'CppExceptionPtr'+-- will @delete@ it when it is garbage collected, so you must not @delete@ it+-- on your own. This function is called "unsafe" because it is not memory safe+-- by itself, but safe when used correctly; similar to for example+-- 'BS.unsafePackMallocCString'. unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr-unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p+unsafeFromNewCppExceptionPtr = newForeignPtr finalizeAbstractCppExceptionPtr  finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr {-# NOINLINE finalizeAbstractCppExceptionPtr #-}@@ -83,27 +91,36 @@ pattern ExTypeOtherException = 3  -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)+handleForeignCatch :: (Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) handleForeignCatch cont =-  alloca $ \exTypePtr ->-  alloca $ \msgCStringPtr ->-  alloca $ \typCStringPtr ->-  alloca $ \exPtr ->-  alloca $ \haskellExPtrPtr -> do-    poke exTypePtr ExTypeNoException+  allocaBytesAligned (sizeOf (undefined :: Ptr ()) * 5) (alignment (undefined :: Ptr ())) $ \basePtr -> do+    let ptrSize         = sizeOf (undefined :: Ptr ())+        exTypePtr       = castPtr basePtr :: Ptr CInt+        msgCStringPtr   = castPtr (basePtr `plusPtr` ptrSize) :: Ptr CString+        typCStringPtr   = castPtr (basePtr `plusPtr` (ptrSize*2))  :: Ptr CString+        exPtr           = castPtr (basePtr `plusPtr` (ptrSize*3))  :: Ptr (Ptr AbstractCppExceptionPtr)+        haskellExPtrPtr = castPtr (basePtr `plusPtr` (ptrSize*4)) :: Ptr (Ptr ())     -- 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+      res <- cont basePtr       exType <- peek exTypePtr       case exType of         ExTypeNoException -> return (Right res)         ExTypeStdException -> do           ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr++          -- BS.unsafePackMallocCString: safe because setMessageOfStdException+          -- (invoked via tryBlockQuoteExp) sets msgCStringPtr to a newly+          -- malloced string.           errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr++          -- BS.unsafePackMallocCString: safe because currentExceptionTypeName+          -- returns a newly malloced string           mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr+           return (Left (CppStdException ex errMsg mbExcType))         ExTypeHaskellException -> do           haskellExPtr <- peek haskellExPtrPtr@@ -117,7 +134,11 @@           return (Left (CppHaskellException someExc))         ExTypeOtherException -> do           ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr++          -- BS.unsafePackMallocCString: safe because currentExceptionTypeName+          -- returns a newly malloced string           mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr+           return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a)         _ -> error "Unexpected C++ exception type." @@ -126,7 +147,7 @@ throwBlock :: QuasiQuoter throwBlock = QuasiQuoter   { quoteExp = \blockStr -> do-      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]+      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp C.block blockStr) |]   , quotePat = unsupported   , quoteType = unsupported   , quoteDec = unsupported@@ -187,22 +208,20 @@     "jmp_buf" -> "0"     _ -> "{}" -tryBlockQuoteExp :: String -> Q Exp-tryBlockQuoteExp blockStr = do+tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp+tryBlockQuoteExp block 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"+  basePtrVarName <- newName "basePtr"   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 ++ ");"+        , "  void** __inline_c_cpp_base_ptr__ = $(void** " ++ nameBase basePtrVarName ++ ");"+        , "  int* __inline_c_cpp_exception_type__ = (int*)__inline_c_cpp_base_ptr__;"+        , "  const char** __inline_c_cpp_error_message__ = (const char**)(__inline_c_cpp_base_ptr__ + 1);"+        , "  const char** __inline_c_cpp_error_typ__ = (const char**)(__inline_c_cpp_base_ptr__ + 2);"+        , "  std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)(__inline_c_cpp_base_ptr__ + 3);"+        , "  HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)(__inline_c_cpp_base_ptr__ + 4);"+        , "  *__inline_c_cpp_exception_type__ = 0;"         , "  try {"         , body         , "  } catch (const HaskellException &e) {"@@ -222,13 +241,13 @@         , "  }"         , "}"         ]-  [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |]+  [e| handleForeignCatch $ \ $(varP basePtrVarName) -> $(quoteExp 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+  { quoteExp = tryBlockQuoteExp C.block   , quotePat = unsupported   , quoteType = unsupported   , quoteDec = unsupported

@@ -0,0 +1,53 @@+{-# LANGUAGE PatternSynonyms #-}+-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters.++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.C.Inline.Cpp.Unsafe+  ( throwBlock+  , tryBlock+  , catchBlock+  , toSomeException+  ) where++import           Control.Exception.Safe+import qualified Language.C.Inline.Unsafe as Unsafe+import           Language.Haskell.TH.Quote+import           Language.C.Inline.Cpp.Exception (tryBlockQuoteExp)+import           Language.C.Inline.Cpp.Exception (tryBlockQuoteExp,toSomeException)++-- | 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 Unsafe.block 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."++-- | 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 Unsafe.block+  , quotePat = unsupported+  , quoteType = unsupported+  , quoteDec = unsupported+  } where+      unsupported _ = fail "Unsupported quasiquotation."

@@ -41,10 +41,12 @@  data Test data Array a+data Tuple a  C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [   ("Test::Test", [t|Test|]),-  ("std::array", [t|Array|])+  ("std::array", [t|Array|]),+  ("std::tuple", [t|Tuple|])   ] `mappend` StdVector.stdVectorCtx  C.include "<iostream>"@@ -105,6 +107,14 @@           std::cout << (*$(std::array<int,10>* pt))[0] << std::endl;         } |] +    Hspec.it "Template with 6 arguments" $ do+      pt <- [C.block| std::tuple<int,int,int,int,int,int>* {+          return NULL;+      } |] :: IO (Ptr (Tuple '(C.CInt,C.CInt,C.CInt,C.CInt,C.CInt,C.CInt)))+      [C.block| void {+          $(std::tuple<int,int,int,int,int,int>* pt) = NULL;+        } |]+   Hspec.describe "Exception handling" $ do     Hspec.it "std::exceptions are caught" $ do       result <- try [C.catchBlock|@@ -119,6 +129,13 @@         |]        result `shouldBeCppOtherException` (Just "unsigned int")++    Hspec.it "non-exceptions are caught (void *)" $ do+      result <- try [C.catchBlock|+        throw (void *)0xDEADBEEF;+        |]++      result `shouldBeCppOtherException` (Just "void*")      Hspec.it "non-exceptions are caught (std::string)" $ do       result <- try [C.catchBlock|