{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
module Language.C.Inline.Cpp.Exception
( CppException(..)
, CppExceptionPtr
, toSomeException
, throwBlock
, tryBlock
, catchBlock
, tryBlockQuoteExp
) 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"
data CppException
= CppStdException CppExceptionPtr ByteString (Maybe ByteString)
| CppHaskellException SomeException
| CppNonStdException CppExceptionPtr (Maybe ByteString)
instance Show CppException where
showsPrec :: Int -> CppException -> ShowS
showsPrec Int
p (CppStdException CppExceptionPtr
_ ByteString
msg Maybe ByteString
typ) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11) (String -> ShowS
showString String
"CppStdException e " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ByteString
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe ByteString
typ)
showsPrec Int
p (CppHaskellException SomeException
e) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11) (String -> ShowS
showString String
"CppHaskellException " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 SomeException
e)
showsPrec Int
p (CppNonStdException CppExceptionPtr
_ Maybe ByteString
typ) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11) (String -> ShowS
showString String
"CppOtherException e " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe ByteString
typ)
instance Exception CppException where
displayException :: CppException -> String
displayException (CppStdException CppExceptionPtr
_ ByteString
msg Maybe ByteString
_typ) = ByteString -> String
bsToChars ByteString
msg
displayException (CppHaskellException SomeException
e) = forall e. Exception e => e -> String
displayException SomeException
e
displayException (CppNonStdException CppExceptionPtr
_ (Just ByteString
typ)) = String
"exception: Exception of type " forall a. Semigroup a => a -> a -> a
<> ByteString -> String
bsToChars ByteString
typ
displayException (CppNonStdException CppExceptionPtr
_ Maybe ByteString
Nothing) = String
"exception: Non-std exception of unknown type"
type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr
unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr
unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr
unsafeFromNewCppExceptionPtr = forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr AbstractCppExceptionPtr
finalizeAbstractCppExceptionPtr
finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr
{-# NOINLINE finalizeAbstractCppExceptionPtr #-}
finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr
finalizeAbstractCppExceptionPtr =
forall a. IO a -> a
unsafePerformIO
[C.exp|
void (*)(std::exception_ptr *) {
[](std::exception_ptr *v){ delete v; }
}|]
toSomeException :: CppException -> SomeException
toSomeException :: CppException -> SomeException
toSomeException (CppHaskellException SomeException
e) = SomeException
e
toSomeException CppException
x = forall e. Exception e => e -> SomeException
toException CppException
x
pattern ExTypeNoException :: CInt
pattern $bExTypeNoException :: CInt
$mExTypeNoException :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
ExTypeNoException = 0
pattern ExTypeStdException :: CInt
pattern $bExTypeStdException :: CInt
$mExTypeStdException :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
ExTypeStdException = 1
pattern ExTypeHaskellException :: CInt
pattern $bExTypeHaskellException :: CInt
$mExTypeHaskellException :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
ExTypeHaskellException = 2
pattern ExTypeOtherException :: CInt
pattern $bExTypeOtherException :: CInt
$mExTypeOtherException :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
ExTypeOtherException = 3
handleForeignCatch :: (Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)
handleForeignCatch :: forall a. (Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)
handleForeignCatch Ptr (Ptr ()) -> IO a
cont =
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Ptr ()) forall a. Num a => a -> a -> a
* Int
5) (forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: Ptr ())) forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
basePtr -> do
let ptrSize :: Int
ptrSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Ptr ())
exTypePtr :: Ptr CInt
exTypePtr = forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr ())
basePtr :: Ptr CInt
msgCStringPtr :: Ptr CString
msgCStringPtr = forall a b. Ptr a -> Ptr b
castPtr (Ptr (Ptr ())
basePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ptrSize) :: Ptr CString
typCStringPtr :: Ptr CString
typCStringPtr = forall a b. Ptr a -> Ptr b
castPtr (Ptr (Ptr ())
basePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ptrSizeforall a. Num a => a -> a -> a
*Int
2)) :: Ptr CString
exPtr :: Ptr (Ptr AbstractCppExceptionPtr)
exPtr = forall a b. Ptr a -> Ptr b
castPtr (Ptr (Ptr ())
basePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ptrSizeforall a. Num a => a -> a -> a
*Int
3)) :: Ptr (Ptr AbstractCppExceptionPtr)
haskellExPtrPtr :: Ptr (Ptr ())
haskellExPtrPtr = forall a b. Ptr a -> Ptr b
castPtr (Ptr (Ptr ())
basePtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ptrSizeforall a. Num a => a -> a -> a
*Int
4)) :: Ptr (Ptr ())
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
a
res <- Ptr (Ptr ()) -> IO a
cont Ptr (Ptr ())
basePtr
CInt
exType <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
exTypePtr
case CInt
exType of
CInt
ExTypeNoException -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
res)
CInt
ExTypeStdException -> do
CppExceptionPtr
ex <- Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr
unsafeFromNewCppExceptionPtr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr AbstractCppExceptionPtr)
exPtr
ByteString
errMsg <- CString -> IO ByteString
BS.unsafePackMallocCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr CString
msgCStringPtr
Maybe ByteString
mbExcType <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO ByteString
BS.unsafePackMallocCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr CString
typCStringPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (CppExceptionPtr -> ByteString -> Maybe ByteString -> CppException
CppStdException CppExceptionPtr
ex ByteString
errMsg Maybe ByteString
mbExcType))
CInt
ExTypeHaskellException -> do
Ptr ()
haskellExPtr <- forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
haskellExPtrPtr
Ptr ()
stablePtr <- [C.block| void * {
return (static_cast<HaskellException *>($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr;
} |]
SomeException
someExc <- forall a. StablePtr a -> IO a
deRefStablePtr (forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
stablePtr)
[C.block| void{
delete static_cast<HaskellException *>($(void *haskellExPtr));
} |]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (SomeException -> CppException
CppHaskellException SomeException
someExc))
CInt
ExTypeOtherException -> do
CppExceptionPtr
ex <- Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr
unsafeFromNewCppExceptionPtr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr AbstractCppExceptionPtr)
exPtr
Maybe ByteString
mbExcType <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO ByteString
BS.unsafePackMallocCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> IO a
peek Ptr CString
typCStringPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (CppExceptionPtr -> Maybe ByteString -> CppException
CppNonStdException CppExceptionPtr
ex Maybe ByteString
mbExcType)) :: IO (Either CppException a)
CInt
_ -> forall a. HasCallStack => String -> a
error String
"Unexpected C++ exception type."
throwBlock :: QuasiQuoter
throwBlock :: QuasiQuoter
throwBlock = QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = \String
blockStr -> do
[e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp C.block blockStr) |]
, quotePat :: String -> Q Pat
quotePat = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteType :: String -> Q Type
quoteType = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteDec :: String -> Q [Dec]
quoteDec = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
} where
unsupported :: p -> m a
unsupported p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported quasiquotation."
catchBlock :: QuasiQuoter
catchBlock :: QuasiQuoter
catchBlock = QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = \String
blockStr -> QuasiQuoter -> String -> Q Exp
quoteExp QuasiQuoter
throwBlock (String
"void {" forall a. [a] -> [a] -> [a]
++ String
blockStr forall a. [a] -> [a] -> [a]
++ String
"}")
, quotePat :: String -> Q Pat
quotePat = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteType :: String -> Q Type
quoteType = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteDec :: String -> Q [Dec]
quoteDec = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
} where
unsupported :: p -> m a
unsupported p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported quasiquotation."
exceptionalValue :: String -> String
exceptionalValue :: ShowS
exceptionalValue String
typeStr =
case String
typeStr of
String
"void" -> String
""
String
"char" -> String
"0"
String
"short" -> String
"0"
String
"long" -> String
"0"
String
"int" -> String
"0"
String
"int8_t" -> String
"0"
String
"int16_t" -> String
"0"
String
"int32_t" -> String
"0"
String
"int64_t" -> String
"0"
String
"uint8_t" -> String
"0"
String
"uint16_t" -> String
"0"
String
"uint32_t" -> String
"0"
String
"uint64_t" -> String
"0"
String
"float" -> String
"0"
String
"double" -> String
"0"
String
"bool" -> String
"0"
String
"signed char" -> String
"0"
String
"signed short" -> String
"0"
String
"signed int" -> String
"0"
String
"signed long" -> String
"0"
String
"unsigned char" -> String
"0"
String
"unsigned short" -> String
"0"
String
"unsigned int" -> String
"0"
String
"unsigned long" -> String
"0"
String
"size_t" -> String
"0"
String
"wchar_t" -> String
"0"
String
"ptrdiff_t" -> String
"0"
String
"sig_atomic_t" -> String
"0"
String
"intptr_t" -> String
"0"
String
"uintptr_t" -> String
"0"
String
"intmax_t" -> String
"0"
String
"uintmax_t" -> String
"0"
String
"clock_t" -> String
"0"
String
"time_t" -> String
"0"
String
"useconds_t" -> String
"0"
String
"suseconds_t" -> String
"0"
String
"FILE" -> String
"0"
String
"fpos_t" -> String
"0"
String
"jmp_buf" -> String
"0"
String
_ -> String
"{}"
tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp
tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp
tryBlockQuoteExp QuasiQuoter
block String
blockStr = do
let (String
ty, String
body) = String -> (String, String)
C.splitTypedC String
blockStr
[Dec]
_ <- String -> Q [Dec]
C.include String
"HaskellException.hxx"
Name
basePtrVarName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"basePtr"
let inlineCStr :: String
inlineCStr = [String] -> String
unlines
[ String
ty forall a. [a] -> [a] -> [a]
++ String
" {"
, String
" void** __inline_c_cpp_base_ptr__ = $(void** " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
basePtrVarName forall a. [a] -> [a] -> [a]
++ String
");"
, String
" int* __inline_c_cpp_exception_type__ = (int*)__inline_c_cpp_base_ptr__;"
, String
" const char** __inline_c_cpp_error_message__ = (const char**)(__inline_c_cpp_base_ptr__ + 1);"
, String
" const char** __inline_c_cpp_error_typ__ = (const char**)(__inline_c_cpp_base_ptr__ + 2);"
, String
" std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)(__inline_c_cpp_base_ptr__ + 3);"
, String
" HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)(__inline_c_cpp_base_ptr__ + 4);"
, String
" *__inline_c_cpp_exception_type__ = 0;"
, String
" try {"
, String
body
, String
" } catch (const HaskellException &e) {"
, String
" *__inline_c_cpp_exception_type__ = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
ExTypeHaskellException forall a. [a] -> [a] -> [a]
++ String
";"
, String
" *__inline_c_cpp_haskellexception__ = new HaskellException(e);"
, String
" return " forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty forall a. [a] -> [a] -> [a]
++ String
";"
, String
" } catch (const std::exception &e) {"
, String
" *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());"
, String
" *__inline_c_cpp_exception_type__ = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
ExTypeStdException forall a. [a] -> [a] -> [a]
++ String
";"
, String
" setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);"
, String
" return " forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty forall a. [a] -> [a] -> [a]
++ String
";"
, String
" } catch (...) {"
, String
" *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());"
, String
" *__inline_c_cpp_exception_type__ = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
ExTypeOtherException forall a. [a] -> [a] -> [a]
++ String
";"
, String
" setCppExceptionType(__inline_c_cpp_error_typ__);"
, String
" return " forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty forall a. [a] -> [a] -> [a]
++ String
";"
, String
" }"
, String
"}"
]
[e| handleForeignCatch $ \ $(varP basePtrVarName) -> $(quoteExp block inlineCStr) |]
tryBlock :: QuasiQuoter
tryBlock :: QuasiQuoter
tryBlock = QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = QuasiQuoter -> String -> Q Exp
tryBlockQuoteExp QuasiQuoter
C.block
, quotePat :: String -> Q Pat
quotePat = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteType :: String -> Q Type
quoteType = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
, quoteDec :: String -> Q [Dec]
quoteDec = forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unsupported
} where
unsupported :: p -> m a
unsupported p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported quasiquotation."
bsToChars :: ByteString -> String
bsToChars :: ByteString -> String
bsToChars = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode