module Foreign.Hoppy.Runtime (
coerceIntegral,
CppEnum (..),
CppPtr (..),
Deletable (..),
Assignable (..),
Copyable (..),
Encodable (..),
encodeAs,
Decodable (..),
decodeAndDelete,
withCppObj,
withScopedPtr,
withScopedFunPtr,
CppException (..),
CppThrowable (..),
catchCpp,
throwCpp,
UnknownCppException,
HasContents (..),
FromContents (..),
CCallback (..),
freeHaskellFunPtrFunPtr,
ExceptionId (..),
SomeCppException (..),
internalHandleExceptions,
internalHandleCallbackExceptions,
ExceptionDb (..),
ExceptionClassInfo (..),
) where
import Control.Exception (Exception, bracket, catch, throwIO)
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Typeable (Typeable, typeOf)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign (
ForeignPtr,
FunPtr,
Ptr,
Storable,
alloca,
freeHaskellFunPtr,
nullPtr,
peek,
poke,
touchForeignPtr,
)
import Foreign.C (
CBool,
CChar,
CDouble,
CFloat,
CInt,
CLLong,
CLong,
CPtrdiff,
CShort,
CSize,
CUChar,
CUInt,
CULLong,
CULong,
CUShort,
)
import GHC.Stack (HasCallStack)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (CSsize)
import Unsafe.Coerce (unsafeCoerce)
foreign import ccall "wrapper" newFreeHaskellFunPtrFunPtr
:: (FunPtr (IO ()) -> IO ())
-> IO (FunPtr (FunPtr (IO ()) -> IO ()))
coerceIntegral :: (Integral a, Integral b, Typeable a, Typeable b, Show a) => a -> b
coerceIntegral :: a -> b
coerceIntegral a
a =
let b :: b
b = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a
a' :: a
a' = b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
b
in if a
a' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
then b
b
else [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Conversion from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (b -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf b
b) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" does not preserve the value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
class CppEnum n e | e -> n where
toCppEnum :: HasCallStack => n -> e
fromCppEnum :: e -> n
class CppPtr this where
nullptr :: this
withCppPtr :: this -> (Ptr this -> IO a) -> IO a
toPtr :: this -> Ptr this
touchCppPtr :: this -> IO ()
class Deletable this where
delete :: this -> IO ()
toGc :: this -> IO this
class Assignable cppType value where
assign :: cppType -> value -> IO ()
instance Assignable (Ptr CBool) Bool where
assign :: Ptr CBool -> Bool -> IO ()
assign Ptr CBool
p Bool
b = Ptr CBool -> CBool -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CBool
p (CBool -> IO ()) -> CBool -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
b then CBool
1 else CBool
0
instance Assignable (Ptr CInt) Int where
assign :: Ptr CInt -> Int -> IO ()
assign Ptr CInt
p Int
i = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
p (CInt -> IO ()) -> CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b.
(Integral a, Integral b, Typeable a, Typeable b, Show a) =>
a -> b
coerceIntegral Int
i
instance Assignable (Ptr CFloat) Float where
assign :: Ptr CFloat -> Float -> IO ()
assign Ptr CFloat
p Float
x = Ptr CFloat -> CFloat -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CFloat
p (CFloat -> IO ()) -> CFloat -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
x
instance Assignable (Ptr CDouble) Double where
assign :: Ptr CDouble -> Double -> IO ()
assign Ptr CDouble
p Double
x = Ptr CDouble -> CDouble -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CDouble
p (CDouble -> IO ()) -> CDouble -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
x
instance Storable a => Assignable (Ptr a) a where
assign :: Ptr a -> a -> IO ()
assign = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke
class Copyable from to | from -> to where
copy :: from -> IO to
class Encodable cppPtrType hsType | cppPtrType -> hsType where
encode :: hsType -> IO cppPtrType
encodeAs :: Encodable cppPtrType hsType => cppPtrType -> hsType -> IO cppPtrType
encodeAs :: cppPtrType -> hsType -> IO cppPtrType
encodeAs cppPtrType
to = (cppPtrType -> cppPtrType) -> IO cppPtrType -> IO cppPtrType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (cppPtrType -> cppPtrType -> cppPtrType
forall a. a -> a -> a
`asTypeOf` cppPtrType
to) (IO cppPtrType -> IO cppPtrType)
-> (hsType -> IO cppPtrType) -> hsType -> IO cppPtrType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. hsType -> IO cppPtrType
forall cppPtrType hsType.
Encodable cppPtrType hsType =>
hsType -> IO cppPtrType
encode
class Decodable cppPtrType hsType | cppPtrType -> hsType where
decode :: cppPtrType -> IO hsType
instance Decodable (Ptr CBool) Bool where decode :: Ptr CBool -> IO Bool
decode = (CBool -> Bool) -> IO CBool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CBool -> CBool -> Bool
forall a. Eq a => a -> a -> Bool
/= CBool
0) (IO CBool -> IO Bool)
-> (Ptr CBool -> IO CBool) -> Ptr CBool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CBool -> IO CBool
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CChar) CChar where decode :: Ptr CChar -> IO CChar
decode = Ptr CChar -> IO CChar
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CUChar) CUChar where decode :: Ptr CUChar -> IO CUChar
decode = Ptr CUChar -> IO CUChar
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CShort) CShort where decode :: Ptr CShort -> IO CShort
decode = Ptr CShort -> IO CShort
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CUShort) CUShort where decode :: Ptr CUShort -> IO CUShort
decode = Ptr CUShort -> IO CUShort
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CInt) Int where decode :: Ptr CInt -> IO Int
decode = (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b.
(Integral a, Integral b, Typeable a, Typeable b, Show a) =>
a -> b
coerceIntegral (IO CInt -> IO Int) -> (Ptr CInt -> IO CInt) -> Ptr CInt -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CUInt) CUInt where decode :: Ptr CUInt -> IO CUInt
decode = Ptr CUInt -> IO CUInt
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CLong) CLong where decode :: Ptr CLong -> IO CLong
decode = Ptr CLong -> IO CLong
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CULong) CULong where decode :: Ptr CULong -> IO CULong
decode = Ptr CULong -> IO CULong
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CLLong) CLLong where decode :: Ptr CLLong -> IO CLLong
decode = Ptr CLLong -> IO CLLong
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CULLong) CULLong where decode :: Ptr CULLong -> IO CULLong
decode = Ptr CULLong -> IO CULLong
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CFloat) Float where decode :: Ptr CFloat -> IO Float
decode = (CFloat -> Float) -> IO CFloat -> IO Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CFloat -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (IO CFloat -> IO Float)
-> (Ptr CFloat -> IO CFloat) -> Ptr CFloat -> IO Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CFloat -> IO CFloat
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CDouble) Double where decode :: Ptr CDouble -> IO Double
decode = (CDouble -> Double) -> IO CDouble -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (IO CDouble -> IO Double)
-> (Ptr CDouble -> IO CDouble) -> Ptr CDouble -> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CDouble -> IO CDouble
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Int8) Int8 where decode :: Ptr Int8 -> IO Int8
decode = Ptr Int8 -> IO Int8
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Int16) Int16 where decode :: Ptr Int16 -> IO Int16
decode = Ptr Int16 -> IO Int16
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Int32) Int32 where decode :: Ptr Int32 -> IO Int32
decode = Ptr Int32 -> IO Int32
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Int64) Int64 where decode :: Ptr Int64 -> IO Int64
decode = Ptr Int64 -> IO Int64
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Word8) Word8 where decode :: Ptr Word8 -> IO Word8
decode = Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Word16) Word16 where decode :: Ptr Word16 -> IO Word16
decode = Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Word32) Word32 where decode :: Ptr Word32 -> IO Word32
decode = Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr Word64) Word64 where decode :: Ptr Word64 -> IO Word64
decode = Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CPtrdiff) CPtrdiff where decode :: Ptr CPtrdiff -> IO CPtrdiff
decode = Ptr CPtrdiff -> IO CPtrdiff
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CSize) CSize where decode :: Ptr CSize -> IO CSize
decode = Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr CSsize) CSsize where decode :: Ptr CSsize -> IO CSsize
decode = Ptr CSsize -> IO CSsize
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CBool)) (Ptr CBool) where decode :: Ptr (Ptr CBool) -> IO (Ptr CBool)
decode = Ptr (Ptr CBool) -> IO (Ptr CBool)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CChar)) (Ptr CChar) where decode :: Ptr (Ptr CChar) -> IO (Ptr CChar)
decode = Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CUChar)) (Ptr CUChar) where decode :: Ptr (Ptr CUChar) -> IO (Ptr CUChar)
decode = Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CShort)) (Ptr CShort) where decode :: Ptr (Ptr CShort) -> IO (Ptr CShort)
decode = Ptr (Ptr CShort) -> IO (Ptr CShort)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CUShort)) (Ptr CUShort) where decode :: Ptr (Ptr CUShort) -> IO (Ptr CUShort)
decode = Ptr (Ptr CUShort) -> IO (Ptr CUShort)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CInt)) (Ptr CInt) where decode :: Ptr (Ptr CInt) -> IO (Ptr CInt)
decode = Ptr (Ptr CInt) -> IO (Ptr CInt)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CUInt)) (Ptr CUInt) where decode :: Ptr (Ptr CUInt) -> IO (Ptr CUInt)
decode = Ptr (Ptr CUInt) -> IO (Ptr CUInt)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CLong)) (Ptr CLong) where decode :: Ptr (Ptr CLong) -> IO (Ptr CLong)
decode = Ptr (Ptr CLong) -> IO (Ptr CLong)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CULong)) (Ptr CULong) where decode :: Ptr (Ptr CULong) -> IO (Ptr CULong)
decode = Ptr (Ptr CULong) -> IO (Ptr CULong)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CLLong)) (Ptr CLLong) where decode :: Ptr (Ptr CLLong) -> IO (Ptr CLLong)
decode = Ptr (Ptr CLLong) -> IO (Ptr CLLong)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CULLong)) (Ptr CULLong) where decode :: Ptr (Ptr CULLong) -> IO (Ptr CULLong)
decode = Ptr (Ptr CULLong) -> IO (Ptr CULLong)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CFloat)) (Ptr CFloat) where decode :: Ptr (Ptr CFloat) -> IO (Ptr CFloat)
decode = Ptr (Ptr CFloat) -> IO (Ptr CFloat)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CDouble)) (Ptr CDouble) where decode :: Ptr (Ptr CDouble) -> IO (Ptr CDouble)
decode = Ptr (Ptr CDouble) -> IO (Ptr CDouble)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Int8)) (Ptr Int8) where decode :: Ptr (Ptr Int8) -> IO (Ptr Int8)
decode = Ptr (Ptr Int8) -> IO (Ptr Int8)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Int16)) (Ptr Int16) where decode :: Ptr (Ptr Int16) -> IO (Ptr Int16)
decode = Ptr (Ptr Int16) -> IO (Ptr Int16)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Int32)) (Ptr Int32) where decode :: Ptr (Ptr Int32) -> IO (Ptr Int32)
decode = Ptr (Ptr Int32) -> IO (Ptr Int32)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Int64)) (Ptr Int64) where decode :: Ptr (Ptr Int64) -> IO (Ptr Int64)
decode = Ptr (Ptr Int64) -> IO (Ptr Int64)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Word8)) (Ptr Word8) where decode :: Ptr (Ptr Word8) -> IO (Ptr Word8)
decode = Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Word16)) (Ptr Word16) where decode :: Ptr (Ptr Word16) -> IO (Ptr Word16)
decode = Ptr (Ptr Word16) -> IO (Ptr Word16)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Word32)) (Ptr Word32) where decode :: Ptr (Ptr Word32) -> IO (Ptr Word32)
decode = Ptr (Ptr Word32) -> IO (Ptr Word32)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr Word64)) (Ptr Word64) where decode :: Ptr (Ptr Word64) -> IO (Ptr Word64)
decode = Ptr (Ptr Word64) -> IO (Ptr Word64)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CPtrdiff)) (Ptr CPtrdiff) where decode :: Ptr (Ptr CPtrdiff) -> IO (Ptr CPtrdiff)
decode = Ptr (Ptr CPtrdiff) -> IO (Ptr CPtrdiff)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CSize)) (Ptr CSize) where decode :: Ptr (Ptr CSize) -> IO (Ptr CSize)
decode = Ptr (Ptr CSize) -> IO (Ptr CSize)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr CSsize)) (Ptr CSsize) where decode :: Ptr (Ptr CSsize) -> IO (Ptr CSsize)
decode = Ptr (Ptr CSsize) -> IO (Ptr CSsize)
forall a. Storable a => Ptr a -> IO a
peek
instance Decodable (Ptr (Ptr (Ptr a))) (Ptr (Ptr a)) where decode :: Ptr (Ptr (Ptr a)) -> IO (Ptr (Ptr a))
decode = Ptr (Ptr (Ptr a)) -> IO (Ptr (Ptr a))
forall a. Storable a => Ptr a -> IO a
peek
decodeAndDelete :: (Deletable cppPtrType, Decodable cppPtrType hsType)
=> cppPtrType -> IO hsType
decodeAndDelete :: cppPtrType -> IO hsType
decodeAndDelete cppPtrType
ptr = do
hsType
result <- cppPtrType -> IO hsType
forall cppPtrType hsType.
Decodable cppPtrType hsType =>
cppPtrType -> IO hsType
decode cppPtrType
ptr
cppPtrType -> IO ()
forall this. Deletable this => this -> IO ()
delete cppPtrType
ptr
hsType -> IO hsType
forall (m :: * -> *) a. Monad m => a -> m a
return hsType
result
withCppObj :: (Deletable cppPtrType, Encodable cppPtrType hsType)
=> hsType -> (cppPtrType -> IO a) -> IO a
withCppObj :: hsType -> (cppPtrType -> IO a) -> IO a
withCppObj hsType
x = IO cppPtrType
-> (cppPtrType -> IO ()) -> (cppPtrType -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (hsType -> IO cppPtrType
forall cppPtrType hsType.
Encodable cppPtrType hsType =>
hsType -> IO cppPtrType
encode hsType
x) cppPtrType -> IO ()
forall this. Deletable this => this -> IO ()
delete
withScopedPtr :: Deletable cppPtrType => IO cppPtrType -> (cppPtrType -> IO a) -> IO a
withScopedPtr :: IO cppPtrType -> (cppPtrType -> IO a) -> IO a
withScopedPtr IO cppPtrType
p = IO cppPtrType
-> (cppPtrType -> IO ()) -> (cppPtrType -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO cppPtrType
p cppPtrType -> IO ()
forall this. Deletable this => this -> IO ()
delete
withScopedFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b
withScopedFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b
withScopedFunPtr IO (FunPtr a)
p = IO (FunPtr a) -> (FunPtr a -> IO ()) -> (FunPtr a -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (FunPtr a)
p FunPtr a -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr
newtype ExceptionId = ExceptionId CInt
deriving (ExceptionId -> ExceptionId -> Bool
(ExceptionId -> ExceptionId -> Bool)
-> (ExceptionId -> ExceptionId -> Bool) -> Eq ExceptionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExceptionId -> ExceptionId -> Bool
$c/= :: ExceptionId -> ExceptionId -> Bool
== :: ExceptionId -> ExceptionId -> Bool
$c== :: ExceptionId -> ExceptionId -> Bool
Eq, Eq ExceptionId
Eq ExceptionId
-> (ExceptionId -> ExceptionId -> Ordering)
-> (ExceptionId -> ExceptionId -> Bool)
-> (ExceptionId -> ExceptionId -> Bool)
-> (ExceptionId -> ExceptionId -> Bool)
-> (ExceptionId -> ExceptionId -> Bool)
-> (ExceptionId -> ExceptionId -> ExceptionId)
-> (ExceptionId -> ExceptionId -> ExceptionId)
-> Ord ExceptionId
ExceptionId -> ExceptionId -> Bool
ExceptionId -> ExceptionId -> Ordering
ExceptionId -> ExceptionId -> ExceptionId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExceptionId -> ExceptionId -> ExceptionId
$cmin :: ExceptionId -> ExceptionId -> ExceptionId
max :: ExceptionId -> ExceptionId -> ExceptionId
$cmax :: ExceptionId -> ExceptionId -> ExceptionId
>= :: ExceptionId -> ExceptionId -> Bool
$c>= :: ExceptionId -> ExceptionId -> Bool
> :: ExceptionId -> ExceptionId -> Bool
$c> :: ExceptionId -> ExceptionId -> Bool
<= :: ExceptionId -> ExceptionId -> Bool
$c<= :: ExceptionId -> ExceptionId -> Bool
< :: ExceptionId -> ExceptionId -> Bool
$c< :: ExceptionId -> ExceptionId -> Bool
compare :: ExceptionId -> ExceptionId -> Ordering
$ccompare :: ExceptionId -> ExceptionId -> Ordering
$cp1Ord :: Eq ExceptionId
Ord, Int -> ExceptionId -> [Char] -> [Char]
[ExceptionId] -> [Char] -> [Char]
ExceptionId -> [Char]
(Int -> ExceptionId -> [Char] -> [Char])
-> (ExceptionId -> [Char])
-> ([ExceptionId] -> [Char] -> [Char])
-> Show ExceptionId
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ExceptionId] -> [Char] -> [Char]
$cshowList :: [ExceptionId] -> [Char] -> [Char]
show :: ExceptionId -> [Char]
$cshow :: ExceptionId -> [Char]
showsPrec :: Int -> ExceptionId -> [Char] -> [Char]
$cshowsPrec :: Int -> ExceptionId -> [Char] -> [Char]
Show)
class CppException e where
cppExceptionInfo :: e -> ExceptionClassInfo
cppExceptionBuild :: ForeignPtr () -> Ptr () -> e
cppExceptionBuildToGc :: Ptr () -> IO e
class CppException e => CppThrowable e where
toSomeCppException :: e -> SomeCppException
catchCpp :: forall a e. CppException e => IO a -> (e -> IO a) -> IO a
catchCpp :: IO a -> (e -> IO a) -> IO a
catchCpp IO a
action e -> IO a
handler = do
let expectedId :: ExceptionId
expectedId = ExceptionClassInfo -> ExceptionId
exceptionClassId (ExceptionClassInfo -> ExceptionId)
-> ExceptionClassInfo -> ExceptionId
forall a b. (a -> b) -> a -> b
$ e -> ExceptionClassInfo
forall e. CppException e => e -> ExceptionClassInfo
cppExceptionInfo (e
forall a. HasCallStack => a
undefined :: e)
IO a -> (SomeCppException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
action ((SomeCppException -> IO a) -> IO a)
-> (SomeCppException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeCppException
caughtEx -> case SomeCppException
caughtEx of
SomeCppException ExceptionClassInfo
classInfo Maybe (ForeignPtr ())
caughtFPtr Ptr ()
caughtPtr ->
if ExceptionId
expectedId ExceptionId -> ExceptionId -> Bool
forall a. Eq a => a -> a -> Bool
== ExceptionClassInfo -> ExceptionId
exceptionClassId (UnknownCppException -> ExceptionClassInfo
forall e. CppException e => e -> ExceptionClassInfo
cppExceptionInfo UnknownCppException
UnknownCppException)
then do
case Maybe (ForeignPtr ())
caughtFPtr of
Maybe (ForeignPtr ())
Nothing -> ExceptionClassInfo -> Ptr () -> IO ()
exceptionClassDelete ExceptionClassInfo
classInfo Ptr ()
caughtPtr
Just ForeignPtr ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
e -> IO a
handler (e -> IO a) -> e -> IO a
forall a b. (a -> b) -> a -> b
$ UnknownCppException -> e
forall a b. a -> b
unsafeCoerce UnknownCppException
UnknownCppException
else do
let maybeUpcastedPtr :: Maybe (Ptr ())
maybeUpcastedPtr :: Maybe (Ptr ())
maybeUpcastedPtr =
if ExceptionId
expectedId ExceptionId -> ExceptionId -> Bool
forall a. Eq a => a -> a -> Bool
== ExceptionClassInfo -> ExceptionId
exceptionClassId ExceptionClassInfo
classInfo
then Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
caughtPtr
else case ExceptionId
-> Map ExceptionId (Ptr () -> Ptr ()) -> Maybe (Ptr () -> Ptr ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExceptionId
expectedId (Map ExceptionId (Ptr () -> Ptr ()) -> Maybe (Ptr () -> Ptr ()))
-> Map ExceptionId (Ptr () -> Ptr ()) -> Maybe (Ptr () -> Ptr ())
forall a b. (a -> b) -> a -> b
$ ExceptionClassInfo -> Map ExceptionId (Ptr () -> Ptr ())
exceptionClassUpcasts ExceptionClassInfo
classInfo of
Just Ptr () -> Ptr ()
upcast -> Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just (Ptr () -> Maybe (Ptr ())) -> Ptr () -> Maybe (Ptr ())
forall a b. (a -> b) -> a -> b
$ Ptr () -> Ptr ()
upcast Ptr ()
caughtPtr
Maybe (Ptr () -> Ptr ())
Nothing -> Maybe (Ptr ())
forall a. Maybe a
Nothing
case Maybe (Ptr ())
maybeUpcastedPtr of
Just Ptr ()
upcastedPtr -> e -> IO a
handler (e -> IO a) -> IO e -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe (ForeignPtr ())
caughtFPtr of
Just ForeignPtr ()
fptr -> e -> IO e
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> IO e) -> e -> IO e
forall a b. (a -> b) -> a -> b
$ ForeignPtr () -> Ptr () -> e
forall e. CppException e => ForeignPtr () -> Ptr () -> e
cppExceptionBuild ForeignPtr ()
fptr Ptr ()
upcastedPtr
Maybe (ForeignPtr ())
Nothing -> Ptr () -> IO e
forall e. CppException e => Ptr () -> IO e
cppExceptionBuildToGc Ptr ()
upcastedPtr
Maybe (Ptr ())
Nothing -> SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeCppException
caughtEx
SomeCppException
SomeUnknownCppException ->
if ExceptionId
expectedId ExceptionId -> ExceptionId -> Bool
forall a. Eq a => a -> a -> Bool
== ExceptionClassInfo -> ExceptionId
exceptionClassId (UnknownCppException -> ExceptionClassInfo
forall e. CppException e => e -> ExceptionClassInfo
cppExceptionInfo UnknownCppException
UnknownCppException)
then e -> IO a
handler (e -> IO a) -> e -> IO a
forall a b. (a -> b) -> a -> b
$ UnknownCppException -> e
forall a b. a -> b
unsafeCoerce UnknownCppException
UnknownCppException
else SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeCppException
caughtEx
throwCpp :: CppThrowable e => e -> IO a
throwCpp :: e -> IO a
throwCpp = SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeCppException -> IO a) -> (e -> SomeCppException) -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeCppException
forall e. CppThrowable e => e -> SomeCppException
toSomeCppException
data UnknownCppException = UnknownCppException
instance CppException UnknownCppException where
cppExceptionInfo :: UnknownCppException -> ExceptionClassInfo
cppExceptionInfo UnknownCppException
_ = ExceptionClassInfo :: ExceptionId
-> [Char]
-> Map ExceptionId (Ptr () -> Ptr ())
-> (Ptr () -> IO ())
-> (Ptr () -> IO (Ptr ()))
-> (Ptr () -> IO (ForeignPtr ()))
-> ExceptionClassInfo
ExceptionClassInfo
{ exceptionClassId :: ExceptionId
exceptionClassId = CInt -> ExceptionId
ExceptionId CInt
1
, exceptionClassName :: [Char]
exceptionClassName = [Char]
"<Unknown C++ exception>"
, exceptionClassUpcasts :: Map ExceptionId (Ptr () -> Ptr ())
exceptionClassUpcasts = Map ExceptionId (Ptr () -> Ptr ())
forall k a. Map k a
M.empty
, exceptionClassDelete :: Ptr () -> IO ()
exceptionClassDelete = [Char] -> Ptr () -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"UnknownCppException.exceptionClassDelete: Should not get here."
, exceptionClassCopy :: Ptr () -> IO (Ptr ())
exceptionClassCopy = [Char] -> Ptr () -> IO (Ptr ())
forall a. HasCallStack => [Char] -> a
error [Char]
"UnknownCppException.exceptionClassCopy: Should not get here."
, exceptionClassToGc :: Ptr () -> IO (ForeignPtr ())
exceptionClassToGc = [Char] -> Ptr () -> IO (ForeignPtr ())
forall a. HasCallStack => [Char] -> a
error [Char]
"UnknownCppException.exceptionClassToGc: Should not get here."
}
cppExceptionBuild :: ForeignPtr () -> Ptr () -> UnknownCppException
cppExceptionBuild ForeignPtr ()
_ Ptr ()
_ =
[Char] -> UnknownCppException
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: cppExceptionBuild called for UnknownCppException"
cppExceptionBuildToGc :: Ptr () -> IO UnknownCppException
cppExceptionBuildToGc Ptr ()
_ =
[Char] -> IO UnknownCppException
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: cppExceptionBuildToGc called for UnknownCppException"
data SomeCppException =
SomeCppException ExceptionClassInfo (Maybe (ForeignPtr ())) (Ptr ())
| SomeUnknownCppException
deriving (Typeable)
instance Exception SomeCppException
instance Show SomeCppException where
show :: SomeCppException -> [Char]
show (SomeCppException ExceptionClassInfo
info Maybe (ForeignPtr ())
_ Ptr ()
_) =
[Char]
"<SomeCppException " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ExceptionClassInfo -> [Char]
exceptionClassName ExceptionClassInfo
info [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
show SomeCppException
SomeUnknownCppException =
ExceptionClassInfo -> [Char]
exceptionClassName (ExceptionClassInfo -> [Char]) -> ExceptionClassInfo -> [Char]
forall a b. (a -> b) -> a -> b
$ UnknownCppException -> ExceptionClassInfo
forall e. CppException e => e -> ExceptionClassInfo
cppExceptionInfo (UnknownCppException
forall a. HasCallStack => a
undefined :: UnknownCppException)
internalHandleExceptions :: ExceptionDb -> (Ptr CInt -> Ptr (Ptr ()) -> IO a) -> IO a
internalHandleExceptions :: ExceptionDb -> (Ptr CInt -> Ptr (Ptr ()) -> IO a) -> IO a
internalHandleExceptions (ExceptionDb Map ExceptionId ExceptionClassInfo
db) Ptr CInt -> Ptr (Ptr ()) -> IO a
f =
(Ptr CInt -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO a) -> IO a) -> (Ptr CInt -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
excIdPtr ->
(Ptr (Ptr ()) -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr ()) -> IO a) -> IO a) -> (Ptr (Ptr ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
excPtrPtr -> do
a
result <- Ptr CInt -> Ptr (Ptr ()) -> IO a
f Ptr CInt
excIdPtr Ptr (Ptr ())
excPtrPtr
CInt
excId <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
excIdPtr
case CInt
excId of
CInt
0 -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
CInt
1 -> SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeCppException
SomeUnknownCppException
CInt
_ -> do Ptr ()
excPtr <- Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
excPtrPtr
case ExceptionId
-> Map ExceptionId ExceptionClassInfo -> Maybe ExceptionClassInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (CInt -> ExceptionId
ExceptionId CInt
excId) Map ExceptionId ExceptionClassInfo
db of
Just ExceptionClassInfo
info -> do
ForeignPtr ()
fptr <- ExceptionClassInfo -> Ptr () -> IO (ForeignPtr ())
exceptionClassToGc ExceptionClassInfo
info Ptr ()
excPtr
SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeCppException -> IO a) -> SomeCppException -> IO a
forall a b. (a -> b) -> a -> b
$ ExceptionClassInfo
-> Maybe (ForeignPtr ()) -> Ptr () -> SomeCppException
SomeCppException ExceptionClassInfo
info (ForeignPtr () -> Maybe (ForeignPtr ())
forall a. a -> Maybe a
Just ForeignPtr ()
fptr) Ptr ()
excPtr
Maybe ExceptionClassInfo
Nothing ->
[Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
[Char]
"internalHandleExceptions: Received C++ exception with unknown exception ID " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
excId [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
internalHandleCallbackExceptions :: CppDefault a => Ptr CInt -> Ptr (Ptr ()) -> IO a -> IO a
internalHandleCallbackExceptions :: Ptr CInt -> Ptr (Ptr ()) -> IO a -> IO a
internalHandleCallbackExceptions Ptr CInt
excIdPtr Ptr (Ptr ())
excPtrPtr IO a
doCall = do
Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
excIdPtr CInt
0
IO a -> (SomeCppException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
doCall ((SomeCppException -> IO a) -> IO a)
-> (SomeCppException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
SomeCppException ExceptionClassInfo
classInfo Maybe (ForeignPtr ())
caughtFPtr Ptr ()
caughtPtr -> do
let ExceptionId CInt
excId = ExceptionClassInfo -> ExceptionId
exceptionClassId ExceptionClassInfo
classInfo
Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CInt
excIdPtr CInt
excId
Ptr (Ptr ()) -> Ptr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr ())
excPtrPtr (Ptr () -> IO ()) -> IO (Ptr ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe (ForeignPtr ())
caughtFPtr of
Just ForeignPtr ()
fptr -> do
Ptr ()
copiedPtr <- ExceptionClassInfo -> Ptr () -> IO (Ptr ())
exceptionClassCopy ExceptionClassInfo
classInfo Ptr ()
caughtPtr
ForeignPtr () -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr ()
fptr
Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
copiedPtr
Maybe (ForeignPtr ())
Nothing -> Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
caughtPtr
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. CppDefault a => a
cppDefault
SomeCppException
SomeUnknownCppException ->
[Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Can't propagate unknown C++ exception from Haskell to C++."
newtype ExceptionDb = ExceptionDb (Map ExceptionId ExceptionClassInfo)
data ExceptionClassInfo = ExceptionClassInfo
{ ExceptionClassInfo -> ExceptionId
exceptionClassId :: ExceptionId
, ExceptionClassInfo -> [Char]
exceptionClassName :: String
, ExceptionClassInfo -> Map ExceptionId (Ptr () -> Ptr ())
exceptionClassUpcasts :: Map ExceptionId (Ptr () -> Ptr ())
, ExceptionClassInfo -> Ptr () -> IO ()
exceptionClassDelete :: Ptr () -> IO ()
, ExceptionClassInfo -> Ptr () -> IO (Ptr ())
exceptionClassCopy :: Ptr () -> IO (Ptr ())
, ExceptionClassInfo -> Ptr () -> IO (ForeignPtr ())
exceptionClassToGc :: Ptr () -> IO (ForeignPtr ())
}
class HasContents c e | c -> e where
toContents :: c -> IO [e]
class FromContents c e | c -> e where
fromContents :: [e] -> IO c
newtype CCallback fnHsCType = CCallback (Ptr ())
freeHaskellFunPtrFunPtr :: FunPtr (FunPtr (IO ()) -> IO ())
{-# NOINLINE freeHaskellFunPtrFunPtr #-}
freeHaskellFunPtrFunPtr :: FunPtr (FunPtr (IO ()) -> IO ())
freeHaskellFunPtrFunPtr =
IO (FunPtr (FunPtr (IO ()) -> IO ()))
-> FunPtr (FunPtr (IO ()) -> IO ())
forall a. IO a -> a
unsafePerformIO (IO (FunPtr (FunPtr (IO ()) -> IO ()))
-> FunPtr (FunPtr (IO ()) -> IO ()))
-> IO (FunPtr (FunPtr (IO ()) -> IO ()))
-> FunPtr (FunPtr (IO ()) -> IO ())
forall a b. (a -> b) -> a -> b
$ (FunPtr (IO ()) -> IO ()) -> IO (FunPtr (FunPtr (IO ()) -> IO ()))
newFreeHaskellFunPtrFunPtr FunPtr (IO ()) -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr
class CppDefault a where
cppDefault :: a
instance CppDefault () where cppDefault :: ()
cppDefault = ()
instance CppDefault CBool where cppDefault :: CBool
cppDefault = CBool
0
instance CppDefault CChar where cppDefault :: CChar
cppDefault = CChar
0
instance CppDefault CUChar where cppDefault :: CUChar
cppDefault = CUChar
0
instance CppDefault CShort where cppDefault :: CShort
cppDefault = CShort
0
instance CppDefault CUShort where cppDefault :: CUShort
cppDefault = CUShort
0
instance CppDefault CInt where cppDefault :: CInt
cppDefault = CInt
0
instance CppDefault CUInt where cppDefault :: CUInt
cppDefault = CUInt
0
instance CppDefault CLong where cppDefault :: CLong
cppDefault = CLong
0
instance CppDefault CULong where cppDefault :: CULong
cppDefault = CULong
0
instance CppDefault CLLong where cppDefault :: CLLong
cppDefault = CLLong
0
instance CppDefault CULLong where cppDefault :: CULLong
cppDefault = CULLong
0
instance CppDefault CFloat where cppDefault :: CFloat
cppDefault = CFloat
0
instance CppDefault CDouble where cppDefault :: CDouble
cppDefault = CDouble
0
instance CppDefault Int8 where cppDefault :: Int8
cppDefault = Int8
0
instance CppDefault Int16 where cppDefault :: Int16
cppDefault = Int16
0
instance CppDefault Int32 where cppDefault :: Int32
cppDefault = Int32
0
instance CppDefault Int64 where cppDefault :: Int64
cppDefault = Int64
0
instance CppDefault Word8 where cppDefault :: Word8
cppDefault = Word8
0
instance CppDefault Word16 where cppDefault :: Word16
cppDefault = Word16
0
instance CppDefault Word32 where cppDefault :: Word32
cppDefault = Word32
0
instance CppDefault Word64 where cppDefault :: Word64
cppDefault = Word64
0
instance CppDefault CPtrdiff where cppDefault :: CPtrdiff
cppDefault = CPtrdiff
0
instance CppDefault CSize where cppDefault :: CSize
cppDefault = CSize
0
instance CppDefault CSsize where cppDefault :: CSsize
cppDefault = CSsize
0
instance CppDefault (Ptr a) where cppDefault :: Ptr a
cppDefault = Ptr a
forall a. Ptr a
nullPtr