diff --git a/cxx-src/HaskellException.cxx b/cxx-src/HaskellException.cxx --- a/cxx-src/HaskellException.cxx +++ b/cxx-src/HaskellException.cxx @@ -28,7 +28,16 @@ { } +#ifdef __APPLE__ +HaskellException::~HaskellException() _NOEXCEPT +{ + haskellExceptionStablePtr.reset(); +} + +const char* HaskellException::what() const _NOEXCEPT { +#else const char* HaskellException::what() const noexcept { +#endif return displayExceptionValue.c_str(); } @@ -45,25 +54,18 @@ } #endif -void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__){ -#if defined(__GNUC__) || defined(__clang__) - const char* demangle_result = currentExceptionTypeName(); - std::string message = "Exception: " + std::string(e.what()) + "; type: " + std::string(demangle_result); -#else - std::string message = "Exception: " + std::string(e.what()) + "; type: not available (please use g++ or clang)"; -#endif - size_t message_len = message.size() + 1; - *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len)); - std::memcpy(*__inline_c_cpp_error_message__, message.c_str(), message_len); +void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typStrPtr){ + *msgStrPtr = strdup(e.what()); + setCppExceptionType(typStrPtr); } -void setMessageOfOtherException(char** __inline_c_cpp_error_message__){ +void setCppExceptionType(char** typStrPtr){ #if defined(__GNUC__) || defined(__clang__) const char* message = currentExceptionTypeName(); size_t message_len = strlen(message) + 1; - *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len)); - std::memcpy(*__inline_c_cpp_error_message__, message, message_len); + *typStrPtr = static_cast(std::malloc(message_len)); + std::memcpy(*typStrPtr, message, message_len); #else - *__inline_c_cpp_error_message__ = NULL; + *typStrPtr = NULL; #endif } diff --git a/include/HaskellException.hxx b/include/HaskellException.hxx --- a/include/HaskellException.hxx +++ b/include/HaskellException.hxx @@ -16,16 +16,25 @@ not know in advance where and how often the exception will be copied, or when it is released. */ +#ifdef __APPLE__ class HaskellException : public std::exception { +#else +class HaskellException : public std::exception { +#endif public: std::shared_ptr haskellExceptionStablePtr; std::string displayExceptionValue; HaskellException(std::string displayExceptionValue, void *haskellExceptionStablePtr); HaskellException(const HaskellException &); +#ifdef __APPLE__ + virtual const char* what() const _NOEXCEPT override; + virtual ~HaskellException() _NOEXCEPT; +#else virtual const char* what() const noexcept override; +#endif }; -void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__); -void setMessageOfOtherException(char** __inline_c_cpp_error_message__); +void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typeStrPtr); +void setCppExceptionType(char** typeStrPtr); diff --git a/inline-c-cpp.cabal b/inline-c-cpp.cabal --- a/inline-c-cpp.cabal +++ b/inline-c-cpp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: inline-c-cpp -version: 0.4.0.3 +version: 0.5.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. @@ -60,10 +60,13 @@ library import: cxx-opts exposed-modules: Language.C.Inline.Cpp + Language.C.Inline.Cpp.Exception Language.C.Inline.Cpp.Exceptions build-depends: base >=4.7 && <5 + , bytestring , inline-c >= 0.9.0.0 , template-haskell + , text , safe-exceptions , containers hs-source-dirs: src @@ -80,7 +83,9 @@ hs-source-dirs: test main-is: tests.hs other-modules: StdVector + , TemplateSpec build-depends: base >=4 && <5 + , bytestring , inline-c , inline-c-cpp , safe-exceptions @@ -89,7 +94,7 @@ , template-haskell , vector default-language: Haskell2010 - cxx-options: -Werror + cxx-options: -Werror -std=c++11 if impl(ghc >= 8.10) ghc-options: diff --git a/src/Language/C/Inline/Cpp.hs b/src/Language/C/Inline/Cpp.hs --- a/src/Language/C/Inline/Cpp.hs +++ b/src/Language/C/Inline/Cpp.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + -- | Module exposing a 'Context' to inline C++ code. We only have used -- this for experiments, so use with caution. See the C++ tests to see -- how to build inline C++ code. @@ -6,6 +10,7 @@ , cppCtx , cppTypePairs , using + , AbstractCppExceptionPtr ) where import Data.Monoid ((<>), mempty) @@ -27,7 +32,11 @@ { ctxForeignSrcLang = Just TH.LangCxx , ctxOutput = Just $ \s -> "extern \"C\" {\n" ++ s ++ "\n}" , ctxEnableCpp = True + , ctxTypesTable = Map.singleton (CT.TypeName "std::exception_ptr") [t|AbstractCppExceptionPtr|] } + +-- | Marks an @std::exception_ptr@. Only used via 'Ptr'. +data AbstractCppExceptionPtr -- | Emits an @using@ directive, e.g. -- diff --git a/src/Language/C/Inline/Cpp/Exception.hs b/src/Language/C/Inline/Cpp/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/Cpp/Exception.hs @@ -0,0 +1,239 @@ +-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Language.C.Inline.Cpp.Exception + ( CppException(..) + , CppExceptionPtr + , toSomeException + , throwBlock + , tryBlock + , catchBlock + ) where + +import Control.Exception.Safe +import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString) +import Data.ByteString (ByteString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +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.C.Inline.Cpp (AbstractCppExceptionPtr) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Foreign +import Foreign.C +import System.IO.Unsafe(unsafePerformIO) + +C.context Cpp.cppCtx +C.include "HaskellException.hxx" + +-- | An exception thrown in C++ code. +data CppException + = CppStdException CppExceptionPtr ByteString (Maybe ByteString) + | CppHaskellException SomeException + | CppNonStdException CppExceptionPtr (Maybe ByteString) + +instance Show CppException where + showsPrec p (CppStdException _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showsPrec 11 typ) + showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e) + showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ) + +instance Exception CppException where + displayException (CppStdException _ msg _typ) = bsToChars msg + displayException (CppHaskellException e) = displayException e + displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ + displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type" + +type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr + +unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr +unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p + +finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr +{-# NOINLINE finalizeAbstractCppExceptionPtr #-} +finalizeAbstractCppExceptionPtr = + unsafePerformIO + [C.exp| + void (*)(std::exception_ptr *) { + [](std::exception_ptr *v){ delete v; } + }|] + +-- | Like 'toException' but unwrap 'CppHaskellException' +toSomeException :: CppException -> SomeException +toSomeException (CppHaskellException e) = e +toSomeException x = toException x + +-- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future. +pattern ExTypeNoException :: CInt +pattern ExTypeNoException = 0 + +pattern ExTypeStdException :: CInt +pattern ExTypeStdException = 1 + +pattern ExTypeHaskellException :: CInt +pattern ExTypeHaskellException = 2 + +pattern ExTypeOtherException :: CInt +pattern ExTypeOtherException = 3 + + +handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) +handleForeignCatch cont = + alloca $ \exTypePtr -> + alloca $ \msgCStringPtr -> + alloca $ \typCStringPtr -> + alloca $ \exPtr -> + 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 msgCStringPtr typCStringPtr exPtr haskellExPtrPtr + exType <- peek exTypePtr + case exType of + ExTypeNoException -> return (Right res) + ExTypeStdException -> do + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppStdException ex errMsg mbExcType)) + 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 + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) + _ -> error "Unexpected C++ exception type." + +-- | 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 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." + +exceptionalValue :: String -> String +exceptionalValue typeStr = + case typeStr of + "void" -> "" + "char" -> "0" + "short" -> "0" + "long" -> "0" + "int" -> "0" + "int8_t" -> "0" + "int16_t" -> "0" + "int32_t" -> "0" + "int64_t" -> "0" + "uint8_t" -> "0" + "uint16_t" -> "0" + "uint32_t" -> "0" + "uint64_t" -> "0" + "float" -> "0" + "double" -> "0" + "bool" -> "0" + "signed char" -> "0" + "signed short" -> "0" + "signed int" -> "0" + "signed long" -> "0" + "unsigned char" -> "0" + "unsigned short" -> "0" + "unsigned int" -> "0" + "unsigned long" -> "0" + "size_t" -> "0" + "wchar_t" -> "0" + "ptrdiff_t" -> "0" + "sig_atomic_t" -> "0" + "intptr_t" -> "0" + "uintptr_t" -> "0" + "intmax_t" -> "0" + "uintmax_t" -> "0" + "clock_t" -> "0" + "time_t" -> "0" + "useconds_t" -> "0" + "suseconds_t" -> "0" + "FILE" -> "0" + "fpos_t" -> "0" + "jmp_buf" -> "0" + _ -> "{}" + +tryBlockQuoteExp :: String -> Q Exp +tryBlockQuoteExp 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" + 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 ++ ");" + , " try {" + , body + , " } catch (const HaskellException &e) {" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" + , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" + , " return " ++ exceptionalValue ty ++ ";" + , " } catch (const std::exception &e) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" + , " setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);" + , " return " ++ exceptionalValue ty ++ ";" + , " } catch (...) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" + , " setCppExceptionType(__inline_c_cpp_error_typ__);" + , " return " ++ exceptionalValue ty ++ ";" + , " }" + , "}" + ] + [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(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@. +tryBlock :: QuasiQuoter +tryBlock = QuasiQuoter + { quoteExp = tryBlockQuoteExp + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." + +bsToChars :: ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode 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 @@ -1,201 +1,36 @@ --- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. - -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} - -module Language.C.Inline.Cpp.Exceptions - ( CppException(..) +{-# LANGUAGE ViewPatterns #-} +module Language.C.Inline.Cpp.Exceptions {-# DEPRECATED "Language.C.Inline.Cpp.Exceptions is deprecated in favor of Language.C.Inline.Cpp.Exception which changes the CppException data type to preserve the exception for custom error handling." #-} ( + CppException(CppHaskellException) + , pattern Language.C.Inline.Cpp.Exceptions.CppStdException + , pattern Language.C.Inline.Cpp.Exceptions.CppOtherException , toSomeException , throwBlock , tryBlock , catchBlock ) where -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. - | 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. -pattern ExTypeNoException :: CInt -pattern ExTypeNoException = 0 - -pattern ExTypeStdException :: CInt -pattern ExTypeStdException = 1 - -pattern ExTypeHaskellException :: CInt -pattern ExTypeHaskellException = 2 - -pattern ExTypeOtherException :: CInt -pattern ExTypeOtherException = 3 +import Data.ByteString (ByteString) +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text as T +import Language.C.Inline.Cpp.Exception -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) -handleForeignCatch cont = - alloca $ \exTypePtr -> - 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 haskellExPtrPtr - exType <- peek exTypePtr - case exType of - ExTypeNoException -> return (Right res) - ExTypeStdException -> do - msgPtr <- peek msgPtrPtr - 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 - then return Nothing - else do - excType <- peekCString msgPtr - free msgPtr - return (Just excType) - return (Left (CppOtherException mbExcType)) - _ -> error "Unexpected C++ exception type." +bsToChars :: ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode --- | 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 blockStr) |] - , quotePat = unsupported - , quoteType = unsupported - , quoteDec = unsupported - } where - unsupported _ = fail "Unsupported quasiquotation." +cppStdExceptionMessage :: CppException -> Maybe String +cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t +cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)" +cppStdExceptionMessage _ = Nothing --- | 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." +cppNonStdExceptionType :: CppException -> Maybe (Maybe String) +cppNonStdExceptionType (CppNonStdException _ mt) = Just (fmap bsToChars mt) +cppNonStdExceptionType _ = Nothing -exceptionalValue :: String -> String -exceptionalValue typeStr = - case typeStr of - "void" -> "" - "char" -> "0" - "short" -> "0" - "long" -> "0" - "int" -> "0" - "int8_t" -> "0" - "int16_t" -> "0" - "int32_t" -> "0" - "int64_t" -> "0" - "uint8_t" -> "0" - "uint16_t" -> "0" - "uint32_t" -> "0" - "uint64_t" -> "0" - "float" -> "0" - "double" -> "0" - "bool" -> "0" - "signed char" -> "0" - "signed short" -> "0" - "signed int" -> "0" - "signed long" -> "0" - "unsigned char" -> "0" - "unsigned short" -> "0" - "unsigned int" -> "0" - "unsigned long" -> "0" - "size_t" -> "0" - "wchar_t" -> "0" - "ptrdiff_t" -> "0" - "sig_atomic_t" -> "0" - "intptr_t" -> "0" - "uintptr_t" -> "0" - "intmax_t" -> "0" - "uintmax_t" -> "0" - "clock_t" -> "0" - "time_t" -> "0" - "useconds_t" -> "0" - "suseconds_t" -> "0" - "FILE" -> "0" - "fpos_t" -> "0" - "jmp_buf" -> "0" - _ -> "{}" +pattern CppStdException :: String -> CppException +pattern CppStdException s <- (cppStdExceptionMessage -> Just s) -tryBlockQuoteExp :: String -> Q Exp -tryBlockQuoteExp blockStr = do - let (ty, body) = C.splitTypedC blockStr - _ <- C.include "HaskellException.hxx" - typePtrVarName <- newName "exTypePtr" - msgPtrVarName <- newName "msgPtr" - haskellExPtrVarName <- newName "haskellExPtr" - let inlineCStr = unlines - [ 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);" - , " return " ++ exceptionalValue ty ++ ";" - , " } catch (std::exception &e) {" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" - , " setMessageOfStdException(e,__inline_c_cpp_error_message__);" - , " return " ++ exceptionalValue ty ++ ";" - , " } catch (...) {" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" - , " setMessageOfOtherException(__inline_c_cpp_error_message__);" - , " return " ++ exceptionalValue ty ++ ";" - , " }" - , "}" - ] - [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@. -tryBlock :: QuasiQuoter -tryBlock = QuasiQuoter - { quoteExp = tryBlockQuoteExp - , quotePat = unsupported - , quoteType = unsupported - , quoteDec = unsupported - } where - unsupported _ = fail "Unsupported quasiquotation." +pattern CppOtherException :: Maybe String -> CppException +pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt) diff --git a/test/TemplateSpec.hs b/test/TemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/TemplateSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module TemplateSpec where + +import qualified Language.C.Inline.Cpp as C +import qualified Language.C.Inline.Context as CC +import qualified Language.C.Types as CT +import Foreign +import Foreign.C +import Data.Monoid + +data CppVector a + +C.context $ + C.cppCtx + <> + C.cppTypePairs [ + ("std::vector" :: CT.CIdentifier, [t|CppVector|]) + ] + +C.include "" +C.include "" + +-- compiles: we can return std::vector* +returns_vec_of_int = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CInt)) + +-- compiles: we can return std::vector* +returns_vec_of_signed = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CInt)) + +-- compiles: we can return std::vector* +returns_vec_of_unsigned = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CUInt)) + +-- compiles: we can return std::vector* +returns_vec_of_long_int = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CLong)) + +-- compiles: we can return std::vector* +returns_vec_of_short = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CShort)) + +-- compiles: we can return std::vector* +returns_vec_of_short_int = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CShort)) + +-- compiles: we can return std::vector* +returns_vec_of_unsigned_int = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CUInt)) + +-- compiles: we can return long* +returns_ptr_to_long = do + [C.block| long* { + return ( (long*) NULL); + } + |] :: IO (Ptr CLong) + +-- compiles: we can return unsigned long* +returns_ptr_to_unsigned_long = do + [C.block| unsigned long* { + return ( (unsigned long*) NULL); + } + |] :: IO (Ptr CULong) + +-- compiles: we can return std::vector* +returns_vec_of_long = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CLong)) + +-- compiles: we can return std::vector* +returns_vec_of_long_long = do + [C.block| std::vector* { + return ( (std::vector*) NULL); + } + |] :: IO (Ptr (CppVector CLLong)) + diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -17,13 +17,17 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} import Control.Exception.Safe import Control.Monad +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) import qualified Language.C.Inline.Cpp as C 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 qualified Language.C.Inline.Cpp.Exception as C +import qualified Language.C.Inline.Cpp.Exceptions as Legacy import Foreign.C.String (withCString) import Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) import qualified Test.Hspec as Hspec @@ -34,10 +38,11 @@ import qualified StdVector import qualified Data.Vector.Storable as VS + data Test data Array a -C.context $ C.cppCtx `mappend` C.cppTypePairs [ +C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [ ("Test::Test", [t|Test|]), ("std::array", [t|Array|]) ] `mappend` StdVector.stdVectorCtx @@ -121,7 +126,24 @@ |] case result of - Left (C.CppOtherException (Just ty)) | "string" `isInfixOf` ty -> return () + Left (C.CppNonStdException ex (Just ty)) -> do + ("string" `BS.isInfixOf` ty) `shouldBe` True + [C.throwBlock| int { + std::exception_ptr *e = $fptr-ptr:(std::exception_ptr *ex); + if (!e) throw std::runtime_error("Exception was null"); + try { + std::cerr << "throwing..." << std::endl; + std::rethrow_exception(*e); + } catch (std::string &foobar) { + if (foobar == "FOOBAR") + return 42; + else + return 1; + } catch (...) { + return 2; + } + return 3; + }|] >>= \r -> r `shouldBe` 42 _ -> error ("Expected Left CppOtherException with string type, but got " ++ show result) Hspec.it "catch without return (pure)" $ do @@ -268,21 +290,23 @@ *a = 100; $(std::vector* pt)->push_back(a); std::cout << *((*$(std::vector* pt))[0]) << std::endl; + delete a; + delete $(std::vector* pt); } |] tag :: C.CppException -> String tag (C.CppStdException {}) = "CppStdException" tag (C.CppHaskellException {}) = "CppHaskellException" -tag (C.CppOtherException {}) = "CppStdException" +tag (Legacy.CppOtherException {}) = "CppStdException" shouldBeCppStdException :: Either C.CppException a -> String -> IO () -shouldBeCppStdException (Left (C.CppStdException actualMsg)) expectedMsg = do +shouldBeCppStdException (Left (Legacy.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 +shouldBeCppOtherException (Left (Legacy.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 <> ")")