-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters.

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}

module Language.C.Inline.Cpp.Exceptions
  ( CppException(..)
  , 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 (Int -> CppException -> ShowS
[CppException] -> ShowS
CppException -> String
(Int -> CppException -> ShowS)
-> (CppException -> String)
-> ([CppException] -> ShowS)
-> Show CppException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CppException] -> ShowS
$cshowList :: [CppException] -> ShowS
show :: CppException -> String
$cshow :: CppException -> String
showsPrec :: Int -> CppException -> ShowS
$cshowsPrec :: Int -> CppException -> ShowS
Show)

-- | Like 'toException' but unwrap 'CppHaskellException'
toSomeException :: CppException -> SomeException
toSomeException :: CppException -> SomeException
toSomeException (CppHaskellException SomeException
e) = SomeException
e
toSomeException CppException
x = CppException -> SomeException
forall e. Exception e => e -> SomeException
toException CppException
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 $bExTypeNoException :: CInt
$mExTypeNoException :: forall r. CInt -> (Void# -> r) -> (Void# -> r) -> r
ExTypeNoException = 0

pattern ExTypeStdException :: CInt
pattern $bExTypeStdException :: CInt
$mExTypeStdException :: forall r. CInt -> (Void# -> r) -> (Void# -> r) -> r
ExTypeStdException = 1

pattern ExTypeHaskellException :: CInt
pattern $bExTypeHaskellException :: CInt
$mExTypeHaskellException :: forall r. CInt -> (Void# -> r) -> (Void# -> r) -> r
ExTypeHaskellException = 2

pattern ExTypeOtherException :: CInt
pattern $bExTypeOtherException :: CInt
$mExTypeOtherException :: forall r. CInt -> (Void# -> r) -> (Void# -> r) -> r
ExTypeOtherException = 3

handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)
handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a)
-> IO (Either CppException a)
handleForeignCatch Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a
cont =
  (Ptr CInt -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Either CppException a))
 -> IO (Either CppException a))
-> (Ptr CInt -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
exTypePtr ->
  (Ptr CString -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO (Either CppException a))
 -> IO (Either CppException a))
-> (Ptr CString -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. (a -> b) -> a -> b
$ \Ptr CString
msgPtrPtr ->
  (Ptr (Ptr ()) -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr ()) -> IO (Either CppException a))
 -> IO (Either CppException a))
-> (Ptr (Ptr ()) -> IO (Either CppException a))
-> IO (Either CppException a)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
haskellExPtrPtr -> do
    Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
exTypePtr CInt
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.
    IO (Either CppException a) -> IO (Either CppException a)
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (IO (Either CppException a) -> IO (Either CppException a))
-> IO (Either CppException a) -> IO (Either CppException a)
forall a b. (a -> b) -> a -> b
$ do
      a
res <- Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a
cont Ptr CInt
exTypePtr Ptr CString
msgPtrPtr Ptr (Ptr ())
haskellExPtrPtr
      CInt
exType <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
exTypePtr
      case CInt
exType of
        CInt
ExTypeNoException -> Either CppException a -> IO (Either CppException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either CppException a
forall a b. b -> Either a b
Right a
res)
        CInt
ExTypeStdException -> do
          CString
msgPtr <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
msgPtrPtr
          String
errMsg <- CString -> IO String
peekCString CString
msgPtr
          CString -> IO ()
forall a. Ptr a -> IO ()
free CString
msgPtr
          Either CppException a -> IO (Either CppException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CppException -> Either CppException a
forall a b. a -> Either a b
Left (String -> CppException
CppStdException String
errMsg))
        CInt
ExTypeHaskellException -> do
          Ptr ()
haskellExPtr <- Ptr (Ptr ()) -> IO (Ptr ())
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 <- StablePtr SomeException -> IO SomeException
forall a. StablePtr a -> IO a
deRefStablePtr (Ptr () -> StablePtr SomeException
forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
stablePtr)
          [C.block| void{
              delete static_cast<HaskellException *>($(void *haskellExPtr));
            } |]
          Either CppException a -> IO (Either CppException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CppException -> Either CppException a
forall a b. a -> Either a b
Left (SomeException -> CppException
CppHaskellException SomeException
someExc))
        CInt
ExTypeOtherException -> do
          CString
msgPtr <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
msgPtrPtr
          Maybe String
mbExcType <- if CString
msgPtr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
            then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
            else do
              String
excType <- CString -> IO String
peekCString CString
msgPtr
              CString -> IO ()
forall a. Ptr a -> IO ()
free CString
msgPtr
              Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
excType)
          Either CppException a -> IO (Either CppException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CppException -> Either CppException a
forall a b. a -> Either a b
Left (Maybe String -> CppException
CppOtherException Maybe String
mbExcType))
        CInt
_ -> String -> IO (Either CppException a)
forall a. HasCallStack => String -> a
error String
"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
throwBlock = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = \String
blockStr -> do
      [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]
  , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  } where
      unsupported :: p -> m a
unsupported p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported quasiquotation."

-- | Variant of 'throwBlock' for blocks which return 'void'.
catchBlock :: QuasiQuoter
catchBlock :: QuasiQuoter
catchBlock = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = \String
blockStr -> QuasiQuoter -> String -> Q Exp
quoteExp QuasiQuoter
throwBlock (String
"void {" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
blockStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}")
  , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  } where
      unsupported :: p -> m a
unsupported p
_ = String -> m a
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 :: String -> Q Exp
tryBlockQuoteExp :: String -> Q Exp
tryBlockQuoteExp 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
typePtrVarName <- String -> Q Name
newName String
"exTypePtr"
  Name
msgPtrVarName <- String -> Q Name
newName String
"msgPtr"
  Name
haskellExPtrVarName <- String -> Q Name
newName String
"haskellExPtr"
  let inlineCStr :: String
inlineCStr = [String] -> String
unlines
        [ String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" {"
        , String
"  int* __inline_c_cpp_exception_type__ = $(int* " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
typePtrVarName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
");"
        , String
"  char** __inline_c_cpp_error_message__ = $(char** " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
msgPtrVarName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
");"
        , String
"  HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
haskellExPtrVarName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"));"
        , String
"  try {"
        , String
body
        , String
"  } catch (HaskellException &e) {"
        , String
"    *__inline_c_cpp_exception_type__ = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
ExTypeHaskellException String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"    *__inline_c_cpp_haskellexception__ = new HaskellException(e);"
        , String
"    return " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"  } catch (std::exception &e) {"
        , String
"    *__inline_c_cpp_exception_type__ = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
ExTypeStdException String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"    setMessageOfStdException(e,__inline_c_cpp_error_message__);"
        , String
"    return " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"  } catch (...) {"
        , String
"    *__inline_c_cpp_exception_type__ = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
ExTypeOtherException String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"    setMessageOfOtherException(__inline_c_cpp_error_message__);"
        , String
"    return " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
exceptionalValue String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"  }"
        , String
"}"
        ]
  [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
tryBlock = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
tryBlockQuoteExp
  , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
unsupported
  } where
      unsupported :: p -> m a
unsupported p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported quasiquotation."