inline-c-cpp 0.3.1.0 → 0.4.0.0

raw patch · 7 files changed

+217/−22 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• cxx-src/HaskellException.cxx +18/−0
• cxx-src/HaskellStablePtr.cxx +9/−0
• include/HaskellException.hxx +27/−0
• include/HaskellStablePtr.hxx +38/−0
• inline-c-cpp.cabal +7/−2
• src/Language/C/Inline/Cpp/Exceptions.hs +41/−8
• test/tests.hs +77/−12

@@ -0,0 +1,18 @@++#include "HaskellException.hxx"++HaskellException::HaskellException(std::string renderedExceptionIn, void *haskellExceptionStablePtrIn)+  : displayExceptionValue(renderedExceptionIn)+  , haskellExceptionStablePtr(new HaskellStablePtr(haskellExceptionStablePtrIn))+{+}++HaskellException::HaskellException(const HaskellException &other)+  : displayExceptionValue(other.displayExceptionValue)+  , haskellExceptionStablePtr(other.haskellExceptionStablePtr)+{+}++const char* HaskellException::what() const noexcept {+  return displayExceptionValue.c_str();+}

@@ -0,0 +1,9 @@++#include "HaskellStablePtr.hxx"+#include "HsFFI.h"++HaskellStablePtr::~HaskellStablePtr() {+  if (stablePtr != STABLE_PTR_NULL) {+    hs_free_stable_ptr(stablePtr);+  }+}

@@ -0,0 +1,27 @@++#pragma once++#include "HaskellStablePtr.hxx"+#include <memory>+#include <string>++/* A representation of a Haskell exception (SomeException), with a precomputed+   exception message from Control.Exception.displayException.++   The std::exception requires that retrieving the message does not mutate the+   exception object and does not throw exceptions.++   This class uses std::shared_ptr for the exception, because its callers can+   not know in advance where and how often the exception will be copied, or when+   it is released.+ */+class HaskellException : public std::exception {+public:+  std::shared_ptr<HaskellStablePtr> haskellExceptionStablePtr;+  std::string displayExceptionValue;++  HaskellException(std::string displayExceptionValue, void *haskellExceptionStablePtr);+  HaskellException(const HaskellException &);+  virtual const char* what() const noexcept override;++};

@@ -0,0 +1,38 @@++#pragma once++#include "HsFFI.h"++#ifndef STABLE_PTR_NULL+#define STABLE_PTR_NULL (static_cast<HsStablePtr>((void *)0))+#endif++/* This is like a newtype that adds a C++ destructor, allowing C++ to call+   hs_free_stable_ptr when the lifetime ends.++   If you need to pass HaskellStablePtr around, you need to use something like+   std::shared_ptr<HaskellStablePtr> to avoid copying the HaskellStablePtr.++   WARNING: If you copy HaskellStablePtr, you must call the original.setNull()+            method in order to prevent a premature/double free when original+            goes out of scope. This does make the original object invalid.+ */+struct HaskellStablePtr {+  HsStablePtr stablePtr;++  /* Takes ownership of a stable pointer. */+  inline HaskellStablePtr(HsStablePtr s) {+    stablePtr = s;+  }++  /* Calls hs_free_stable_ptr if this.stablePtr is not NULL. */+  ~HaskellStablePtr();++  inline void setNull() {+    stablePtr = STABLE_PTR_NULL;+  }++  operator bool() const {+    return stablePtr != STABLE_PTR_NULL;+  }+};

@@ -1,5 +1,6 @@+cabal-version:       2.2 name:                inline-c-cpp-version:             0.3.1.0+version:             0.4.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.@@ -11,7 +12,6 @@ category:            FFI tested-with:         GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 build-type:          Simple-cabal-version:       >=1.10  source-repository head   type:     git@@ -28,6 +28,11 @@   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall -optc-xc++ -optc-std=c++11+  include-dirs:        include+  install-includes:    HaskellException.hxx HaskellStablePtr.hxx+  extra-libraries:     stdc+++  c-sources:           cxx-src/HaskellException.cxx cxx-src/HaskellStablePtr.cxx+  cc-options:          -Wall -std=c++11   if os(darwin)     -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829     ld-options:        -Wl,-keep_dwarf_unwind

@@ -2,9 +2,11 @@  {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}  module Language.C.Inline.Cpp.Exceptions   ( CppException(..)+  , toSomeException   , throwBlock   , tryBlock   , catchBlock@@ -13,17 +15,27 @@ 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.-  deriving (Eq, Ord, Show)+  | 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.@@ -33,20 +45,24 @@ pattern ExTypeStdException :: CInt pattern ExTypeStdException = 1 +pattern ExTypeHaskellException :: CInt+pattern ExTypeHaskellException = 2+ pattern ExTypeOtherException :: CInt-pattern ExTypeOtherException = 2+pattern ExTypeOtherException = 3 -handleForeignCatch :: (Ptr CInt -> Ptr CString -> IO a) -> IO (Either CppException a)+handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) handleForeignCatch cont =   alloca $ \exTypePtr ->-  alloca $ \msgPtrPtr -> do+  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+      res <- cont exTypePtr msgPtrPtr haskellExPtrPtr       exType <- peek exTypePtr       case exType of         ExTypeNoException -> return (Right res)@@ -55,6 +71,16 @@           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@@ -66,12 +92,12 @@           return (Left (CppOtherException mbExcType))         _ -> error "Unexpected C++ exception type." --- | Like 'tryBlock', but will throw 'CppException's rather than returning+-- | 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 return =<< $(tryBlockQuoteExp blockStr) |]+      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]   , quotePat = unsupported   , quoteType = unsupported   , quoteDec = unsupported@@ -138,6 +164,7 @@   _ <- C.include "<exception>"   _ <- C.include "<cstring>"   _ <- C.include "<cstdlib>"+  _ <- C.include "HaskellException.hxx"   -- see   -- <https://stackoverflow.com/questions/28166565/detect-gcc-as-opposed-to-msvc-clang-with-macro>   -- regarding how to detect g++ or clang.@@ -152,6 +179,7 @@     ]   typePtrVarName <- newName "exTypePtr"   msgPtrVarName <- newName "msgPtr"+  haskellExPtrVarName <- newName "haskellExPtr"   -- see   -- <https://stackoverflow.com/questions/561997/determining-exception-type-after-the-exception-is-caught/47164539#47164539>   -- regarding how to show the type of an exception.@@ -159,8 +187,13 @@         [ 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);"+        , if ty == "void" then "return;" else "return {};"         , "  } catch (std::exception &e) {"         , "    *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";"         , "#if defined(__GNUC__) || defined(__clang__)"@@ -189,7 +222,7 @@         , "  }"         , "}"         ]-  [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(quoteExp C.block inlineCStr) |]+  [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@.

@@ -23,6 +23,8 @@ 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           Foreign.C.String (withCString)+import           Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) import qualified Test.Hspec as Hspec import           Foreign.Ptr (Ptr) import           Data.List (isInfixOf)@@ -44,6 +46,10 @@ C.include "<stdexcept>" C.include "test.h" +data MyCustomException = MyCustomException Int+  deriving (Eq, Show, Typeable)+instance Exception MyCustomException+ main :: IO () main = Hspec.hspec $ do   Hspec.describe "Basic C++" $ do@@ -94,14 +100,14 @@         throw std::runtime_error("C++ error message");         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"      Hspec.it "non-exceptions are caught (unsigned int)" $ do       result <- try [C.catchBlock|         throw 0xDEADBEEF;         |] -      result `Hspec.shouldBe` Left (C.CppOtherException (Just "unsigned int"))+      result `shouldBeCppOtherException` (Just "unsigned int")      Hspec.it "non-exceptions are caught (std::string)" $ do       result <- try [C.catchBlock|@@ -118,7 +124,7 @@         }         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"      Hspec.it "try and return without throwing (pure)" $ do       result <- [C.tryBlock| int {@@ -126,7 +132,7 @@         }         |] -      result `Hspec.shouldBe` Right 123+      result `shouldBeRight` 123      Hspec.it "return maybe throwing (pure)" $ do       result <- [C.tryBlock| int {@@ -135,7 +141,7 @@         }         |] -      result `Hspec.shouldBe` Right 123+      result `shouldBeRight` 123      Hspec.it "return definitely throwing (pure)" $ do       result <- [C.tryBlock| int {@@ -144,7 +150,7 @@         }         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"      Hspec.it "catch without return (pure)" $ do       result <- [C.tryBlock| void {@@ -152,7 +158,7 @@         }         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"      Hspec.it "try and return without throwing (throw)" $ do       result :: Either C.CppException C.CInt <- try [C.throwBlock| int {@@ -160,7 +166,7 @@         }         |] -      result `Hspec.shouldBe` Right 123+      result `shouldBeRight` 123      Hspec.it "return maybe throwing (throw)" $ do       result :: Either C.CppException C.CInt <- try [C.throwBlock| int {@@ -169,7 +175,7 @@         }         |] -      result `Hspec.shouldBe` Right 123+      result `shouldBeRight` 123      Hspec.it "return definitely throwing (throw)" $ do       result <- try [C.throwBlock| int {@@ -178,19 +184,78 @@         }         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error" +    Hspec.it "return throwing Haskell" $ do+      let exc = toException $ userError "This is from Haskell"++      let doIt = withCString (displayException exc) $ \renderedException -> do++                    stablePtr <- newStablePtr exc+                    let stablePtr' = castStablePtrToPtr stablePtr++                    [C.throwBlock| int {+                        if(0) return 123;+                        else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr')));+                      }+                      |]++      let isTheError e | e == userError "This is from Haskell" = True+          isTheError _ = False++      doIt `Hspec.shouldThrow` isTheError++    Hspec.it "return throwing custom Haskell exception" $ do+      let exc = toException $ MyCustomException 42++      let doIt = withCString (displayException exc) $ \renderedException -> do++                    stablePtr <- newStablePtr exc+                    let stablePtr' = castStablePtrToPtr stablePtr++                    [C.throwBlock| int {+                        if(0) return 123;+                        else throw HaskellException(HaskellException(std::string($(const char *renderedException)), $(void *stablePtr')));+                      }+                      |]++      let isTheError (MyCustomException 42) = True+          isTheError _ = False++      doIt `Hspec.shouldThrow` isTheError+     Hspec.it "catch without return (throw)" $ do       result <- try [C.throwBlock| void {           throw std::runtime_error("C++ error message");         }         |] -      result `Hspec.shouldBe` Left (C.CppStdException "Exception: C++ error message; type: std::runtime_error")+      result `shouldBeCppStdException` "Exception: C++ error message; type: std::runtime_error"      Hspec.it "code without exceptions works normally" $ do       result :: Either C.CppException C.CInt <- try $ C.withPtr_ $ \resPtr -> [C.catchBlock|           *$(int* resPtr) = 0xDEADBEEF;         |] -      result `Hspec.shouldBe` Right 0xDEADBEEF+      result `shouldBeRight` 0xDEADBEEF++tag :: C.CppException -> String+tag (C.CppStdException {}) = "CppStdException"+tag (C.CppHaskellException {}) = "CppHaskellException"+tag (C.CppOtherException {}) = "CppStdException"++shouldBeCppStdException :: Either C.CppException a -> String -> IO ()+shouldBeCppStdException (Left (C.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+  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 <> ")")++shouldBeRight :: (Eq a, Show a) => Either C.CppException a -> a -> IO ()+shouldBeRight (Right actual) expected = actual `Hspec.shouldBe` expected+shouldBeRight (Left e) expected = ("Left (" <> tag e <> " {})") `Hspec.shouldBe` ("Right " <> (show expected))