diff --git a/cxx-src/HaskellException.cxx b/cxx-src/HaskellException.cxx new file mode 100644 --- /dev/null +++ b/cxx-src/HaskellException.cxx @@ -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(); +} diff --git a/cxx-src/HaskellStablePtr.cxx b/cxx-src/HaskellStablePtr.cxx new file mode 100644 --- /dev/null +++ b/cxx-src/HaskellStablePtr.cxx @@ -0,0 +1,9 @@ + +#include "HaskellStablePtr.hxx" +#include "HsFFI.h" + +HaskellStablePtr::~HaskellStablePtr() { + if (stablePtr != STABLE_PTR_NULL) { + hs_free_stable_ptr(stablePtr); + } +} diff --git a/include/HaskellException.hxx b/include/HaskellException.hxx new file mode 100644 --- /dev/null +++ b/include/HaskellException.hxx @@ -0,0 +1,27 @@ + +#pragma once + +#include "HaskellStablePtr.hxx" +#include +#include + +/* 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 haskellExceptionStablePtr; + std::string displayExceptionValue; + + HaskellException(std::string displayExceptionValue, void *haskellExceptionStablePtr); + HaskellException(const HaskellException &); + virtual const char* what() const noexcept override; + +}; diff --git a/include/HaskellStablePtr.hxx b/include/HaskellStablePtr.hxx new file mode 100644 --- /dev/null +++ b/include/HaskellStablePtr.hxx @@ -0,0 +1,38 @@ + +#pragma once + +#include "HsFFI.h" + +#ifndef STABLE_PTR_NULL +#define STABLE_PTR_NULL (static_cast((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 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; + } +}; diff --git a/inline-c-cpp.cabal b/inline-c-cpp.cabal --- a/inline-c-cpp.cabal +++ b/inline-c-cpp.cabal @@ -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 diff --git a/src/Language/C/Inline/Cpp/Exceptions.hs b/src/Language/C/Inline/Cpp/Exceptions.hs --- a/src/Language/C/Inline/Cpp/Exceptions.hs +++ b/src/Language/C/Inline/Cpp/Exceptions.hs @@ -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($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr; + } |] + someExc <- deRefStablePtr (castPtrToStablePtr stablePtr) + [C.block| void{ + delete static_cast($(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 "" _ <- C.include "" _ <- C.include "" + _ <- C.include "HaskellException.hxx" -- see -- -- regarding how to detect g++ or clang. @@ -152,6 +179,7 @@ ] typePtrVarName <- newName "exTypePtr" msgPtrVarName <- newName "msgPtr" + haskellExPtrVarName <- newName "haskellExPtr" -- see -- -- 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@. diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -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 "" 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))