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,5 @@ name: inline-c-cpp -version: 0.2.1.0 +version: 0.2.2.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. @@ -27,6 +27,7 @@ , safe-exceptions hs-source-dirs: src default-language: Haskell2010 + cc-options: -Wall -Werror test-suite tests type: exitcode-stdio-1.0 @@ -39,3 +40,4 @@ , hspec default-language: Haskell2010 extra-libraries: stdc++ + cc-options: -Wall -Werror 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 @@ -5,11 +5,14 @@ module Language.C.Inline.Cpp.Exceptions ( CppException(..) + , throwBlock + , tryBlock , catchBlock ) where import Control.Exception.Safe import qualified Language.C.Inline as C +import qualified Language.C.Inline.Internal as C import Language.Haskell.TH import Language.Haskell.TH.Quote import Foreign @@ -33,54 +36,85 @@ pattern ExTypeOtherException :: CInt pattern ExTypeOtherException = 2 -handleForeign :: (Ptr CInt -> Ptr CString -> IO ()) -> IO () -handleForeign cont = +handleForeignCatch :: (Ptr CInt -> Ptr CString -> IO a) -> IO (Either CppException a) +handleForeignCatch cont = alloca $ \exTypePtr -> alloca $ \msgPtrPtr -> do poke exTypePtr ExTypeNoException - cont exTypePtr msgPtrPtr `finally` do + -- 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 exType <- peek exTypePtr case exType of - ExTypeNoException -> return () + ExTypeNoException -> return (Right res) ExTypeStdException -> do msgPtr <- peek msgPtrPtr errMsg <- peekCString msgPtr free msgPtr - throwM $ CppStdException errMsg + return (Left (CppStdException errMsg)) ExTypeOtherException -> - throwM CppOtherException + return (Left CppOtherException) _ -> error "Unexpected C++ exception type." --- | Similar to `C.block`, but C++ exceptions will be caught and rethrown as `ForeignException`s. --- Unlike `C.block`, the return type can only be @void@ (and doesn't need to be specified), but you can use `C.withPtr_` to extract a result yourself. --- --- Using this will automatically include @exception@, @cstring@ and @cstdlib@. +-- | Like 'tryBlock', but will throw 'CppException's rather than returning +-- them in an 'Either' +throwBlock :: QuasiQuoter +throwBlock = QuasiQuoter + { quoteExp = \blockStr -> do + [e| either throwIO 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 -> do - _ <- C.include "" - _ <- C.include "" - _ <- C.include "" - typePtrVarName <- newName "exTypePtr" - msgPtrVarName <- newName "msgPtr" - let inlineCStr = unlines - [ "void {" - , " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");" - , " char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");" - , " try {" - , blockStr - , " } catch (std::exception &e) {" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" - , " size_t whatLen = std::strlen(e.what()) + 1;" - , " *__inline_c_cpp_error_message__ = static_cast(std::malloc(whatLen));" - , " std::memcpy(*__inline_c_cpp_error_message__, e.what(), whatLen);" - , " } catch (...) {" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" - , " }" - , "}" - ] - [e| handleForeign $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(quoteExp C.block inlineCStr) |] + { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}") + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." + +tryBlockQuoteExp :: String -> Q Exp +tryBlockQuoteExp blockStr = do + let (ty, body) = C.splitTypedC blockStr + _ <- C.include "" + _ <- C.include "" + _ <- C.include "" + typePtrVarName <- newName "exTypePtr" + msgPtrVarName <- newName "msgPtr" + let inlineCStr = unlines + [ ty ++ " {" + , " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");" + , " char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");" + , " try {" + , body + , " } catch (std::exception &e) {" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" + , " size_t whatLen = std::strlen(e.what()) + 1;" + , " *__inline_c_cpp_error_message__ = static_cast(std::malloc(whatLen));" + , " std::memcpy(*__inline_c_cpp_error_message__, e.what(), whatLen);" + , if ty == "void" then "return;" else "return {};" + , " } catch (...) {" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" + , if ty == "void" then "return;" else "return {};" + , " }" + , "}" + ] + [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(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 diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -37,6 +37,82 @@ result `Hspec.shouldBe` Left C.CppOtherException + Hspec.it "catch without return (pure)" $ do + result <- [C.tryBlock| void { + throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Left (C.CppStdException "C++ error message") + + Hspec.it "try and return without throwing (pure)" $ do + result <- [C.tryBlock| int { + return 123; + } + |] + + result `Hspec.shouldBe` Right 123 + + Hspec.it "return maybe throwing (pure)" $ do + result <- [C.tryBlock| int { + if(1) return 123; + else throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Right 123 + + Hspec.it "return definitely throwing (pure)" $ do + result <- [C.tryBlock| int { + if(0) return 123; + else throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Left (C.CppStdException "C++ error message") + + Hspec.it "catch without return (pure)" $ do + result <- [C.tryBlock| void { + throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Left (C.CppStdException "C++ error message") + + Hspec.it "try and return without throwing (throw)" $ do + result :: Either C.CppException C.CInt <- try [C.throwBlock| int { + return 123; + } + |] + + result `Hspec.shouldBe` Right 123 + + Hspec.it "return maybe throwing (throw)" $ do + result :: Either C.CppException C.CInt <- try [C.throwBlock| int { + if(1) return 123; + else throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Right 123 + + Hspec.it "return definitely throwing (throw)" $ do + result <- try [C.throwBlock| int { + if(0) return 123; + else throw std::runtime_error("C++ error message"); + } + |] + + result `Hspec.shouldBe` Left (C.CppStdException "C++ error message") + + 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 "C++ error message") + Hspec.it "code without exceptions works normally" $ do result :: Either C.CppException C.CInt <- try $ C.withPtr_ $ \resPtr -> [C.catchBlock| *$(int* resPtr) = 0xDEADBEEF;