inline-c-cpp 0.2.1.0 → 0.2.2.0
raw patch · 3 files changed
+146/−34 lines, 3 files
Files
- inline-c-cpp.cabal +3/−1
- src/Language/C/Inline/Cpp/Exceptions.hs +67/−33
- test/tests.hs +76/−0
inline-c-cpp.cabal view
@@ -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
src/Language/C/Inline/Cpp/Exceptions.hs view
@@ -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 "<exception>"- _ <- C.include "<cstring>"- _ <- C.include "<cstdlib>"- 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<char*>(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 "<exception>"+ _ <- C.include "<cstring>"+ _ <- C.include "<cstdlib>"+ 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<char*>(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
test/tests.hs view
@@ -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;