{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms #-}
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
import Foreign.C
data CppException
= CppStdException String
| CppOtherException (Maybe String)
deriving (Eq, Ord, Show)
instance Exception CppException
pattern ExTypeNoException :: CInt
pattern ExTypeNoException = 0
pattern ExTypeStdException :: CInt
pattern ExTypeStdException = 1
pattern ExTypeOtherException :: CInt
pattern ExTypeOtherException = 2
handleForeignCatch :: (Ptr CInt -> Ptr CString -> IO a) -> IO (Either CppException a)
handleForeignCatch cont =
alloca $ \exTypePtr ->
alloca $ \msgPtrPtr -> do
poke exTypePtr ExTypeNoException
mask_ $ do
res <- cont exTypePtr msgPtrPtr
exType <- peek exTypePtr
case exType of
ExTypeNoException -> return (Right res)
ExTypeStdException -> do
msgPtr <- peek msgPtrPtr
errMsg <- peekCString msgPtr
free msgPtr
return (Left (CppStdException errMsg))
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."
throwBlock :: QuasiQuoter
throwBlock = QuasiQuoter
{ quoteExp = \blockStr -> do
[e| either throwIO return =<< $(tryBlockQuoteExp blockStr) |]
, quotePat = unsupported
, quoteType = unsupported
, quoteDec = unsupported
} where
unsupported _ = fail "Unsupported quasiquotation."
catchBlock :: QuasiQuoter
catchBlock = QuasiQuoter
{ 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>"
C.verbatim $ unlines
[ "#if defined(__GNUC__) || defined(__clang__)"
, "#include <cxxabi.h>"
, "#include <string>"
, "#endif"
]
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 ++ ";"
, "#if defined(__GNUC__) || defined(__clang__)"
, " int demangle_status;"
, " const char* demangle_result = abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status);"
, " 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<char*>(std::malloc(message_len));"
, " std::memcpy(*__inline_c_cpp_error_message__, message.c_str(), message_len);"
, if ty == "void" then "return;" else "return {};"
, " } catch (...) {"
, " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";"
, "#if defined(__GNUC__) || defined(__clang__)"
, " int demangle_status;"
, " const char* message = abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status);"
, " size_t message_len = strlen(message) + 1;"
, " *__inline_c_cpp_error_message__ = static_cast<char*>(std::malloc(message_len));"
, " std::memcpy(*__inline_c_cpp_error_message__, message, message_len);"
, "#else"
, " *__inline_c_cpp_error_message__ = NULL;"
, "#endif"
, if ty == "void" then "return;" else "return {};"
, " }"
, "}"
]
[e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(quoteExp C.block inlineCStr) |]
tryBlock :: QuasiQuoter
tryBlock = QuasiQuoter
{ quoteExp = tryBlockQuoteExp
, quotePat = unsupported
, quoteType = unsupported
, quoteDec = unsupported
} where
unsupported _ = fail "Unsupported quasiquotation."