module Foreign.Hoppy.Runtime (
CBool (..),
CUChar (CUChar),
coerceIntegral,
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 (
CChar,
CDouble,
CFloat,
CInt,
CLLong,
CLong,
CPtrdiff,
CShort,
CSize,
CUChar (CUChar),
CUInt,
CULLong,
CULong,
CUShort,
)
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 ()))
newtype CBool = CBool CUChar
deriving (Eq, Integral, Num, Ord, Real, Show, Storable)
instance Bounded CBool where
minBound = 0
maxBound = 1
instance Enum CBool where
fromEnum (CBool n) = fromIntegral n
toEnum n =
if n == 0 || n == 1
then CBool $ fromIntegral n
else error $ concat ["CBool.toEnum: Invalid value ", show n, "."]
coerceIntegral :: (Integral a, Integral b, Typeable a, Typeable b, Show a) => a -> b
coerceIntegral a =
let b = fromIntegral a
a' = fromIntegral b
in if a' == a
then b
else error $ "Conversion from " ++ show (typeOf a) ++ " to " ++
show (typeOf b) ++ " does not preserve the value " ++ show a ++ "."
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 p b = poke p $ if b then 1 else 0
instance Assignable (Ptr CInt) Int where
assign p i = poke p $ coerceIntegral i
instance Assignable (Ptr CFloat) Float where
assign p x = poke p $ realToFrac x
instance Assignable (Ptr CDouble) Double where
assign p x = poke p $ realToFrac x
instance Storable a => Assignable (Ptr a) a where
assign = 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 to = fmap (`asTypeOf` to) . encode
class Decodable cppPtrType hsType | cppPtrType -> hsType where
decode :: cppPtrType -> IO hsType
instance Decodable (Ptr CBool) Bool where decode = fmap (/= 0) . peek
instance Decodable (Ptr CChar) CChar where decode = peek
instance Decodable (Ptr CUChar) CUChar where decode = peek
instance Decodable (Ptr CShort) CShort where decode = peek
instance Decodable (Ptr CUShort) CUShort where decode = peek
instance Decodable (Ptr CInt) Int where decode = fmap coerceIntegral . peek
instance Decodable (Ptr CUInt) CUInt where decode = peek
instance Decodable (Ptr CLong) CLong where decode = peek
instance Decodable (Ptr CULong) CULong where decode = peek
instance Decodable (Ptr CLLong) CLLong where decode = peek
instance Decodable (Ptr CULLong) CULLong where decode = peek
instance Decodable (Ptr CFloat) Float where decode = fmap realToFrac . peek
instance Decodable (Ptr CDouble) Double where decode = fmap realToFrac . peek
instance Decodable (Ptr Int8) Int8 where decode = peek
instance Decodable (Ptr Int16) Int16 where decode = peek
instance Decodable (Ptr Int32) Int32 where decode = peek
instance Decodable (Ptr Int64) Int64 where decode = peek
instance Decodable (Ptr Word8) Word8 where decode = peek
instance Decodable (Ptr Word16) Word16 where decode = peek
instance Decodable (Ptr Word32) Word32 where decode = peek
instance Decodable (Ptr Word64) Word64 where decode = peek
instance Decodable (Ptr CPtrdiff) CPtrdiff where decode = peek
instance Decodable (Ptr CSize) CSize where decode = peek
instance Decodable (Ptr CSsize) CSsize where decode = peek
instance Decodable (Ptr (Ptr CBool)) (Ptr CBool) where decode = peek
instance Decodable (Ptr (Ptr CChar)) (Ptr CChar) where decode = peek
instance Decodable (Ptr (Ptr CUChar)) (Ptr CUChar) where decode = peek
instance Decodable (Ptr (Ptr CShort)) (Ptr CShort) where decode = peek
instance Decodable (Ptr (Ptr CUShort)) (Ptr CUShort) where decode = peek
instance Decodable (Ptr (Ptr CInt)) (Ptr CInt) where decode = peek
instance Decodable (Ptr (Ptr CUInt)) (Ptr CUInt) where decode = peek
instance Decodable (Ptr (Ptr CLong)) (Ptr CLong) where decode = peek
instance Decodable (Ptr (Ptr CULong)) (Ptr CULong) where decode = peek
instance Decodable (Ptr (Ptr CLLong)) (Ptr CLLong) where decode = peek
instance Decodable (Ptr (Ptr CULLong)) (Ptr CULLong) where decode = peek
instance Decodable (Ptr (Ptr CFloat)) (Ptr CFloat) where decode = peek
instance Decodable (Ptr (Ptr CDouble)) (Ptr CDouble) where decode = peek
instance Decodable (Ptr (Ptr Int8)) (Ptr Int8) where decode = peek
instance Decodable (Ptr (Ptr Int16)) (Ptr Int16) where decode = peek
instance Decodable (Ptr (Ptr Int32)) (Ptr Int32) where decode = peek
instance Decodable (Ptr (Ptr Int64)) (Ptr Int64) where decode = peek
instance Decodable (Ptr (Ptr Word8)) (Ptr Word8) where decode = peek
instance Decodable (Ptr (Ptr Word16)) (Ptr Word16) where decode = peek
instance Decodable (Ptr (Ptr Word32)) (Ptr Word32) where decode = peek
instance Decodable (Ptr (Ptr Word64)) (Ptr Word64) where decode = peek
instance Decodable (Ptr (Ptr CPtrdiff)) (Ptr CPtrdiff) where decode = peek
instance Decodable (Ptr (Ptr CSize)) (Ptr CSize) where decode = peek
instance Decodable (Ptr (Ptr CSsize)) (Ptr CSsize) where decode = peek
instance Decodable (Ptr (Ptr (Ptr a))) (Ptr (Ptr a)) where decode = peek
decodeAndDelete :: (Deletable cppPtrType, Decodable cppPtrType hsType)
=> cppPtrType -> IO hsType
decodeAndDelete ptr = do
result <- decode ptr
delete ptr
return result
withCppObj :: (Deletable cppPtrType, Encodable cppPtrType hsType)
=> hsType -> (cppPtrType -> IO a) -> IO a
withCppObj x = bracket (encode x) delete
withScopedPtr :: Deletable cppPtrType => IO cppPtrType -> (cppPtrType -> IO a) -> IO a
withScopedPtr p = bracket p delete
withScopedFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b
withScopedFunPtr p = bracket p freeHaskellFunPtr
newtype ExceptionId = ExceptionId CInt
deriving (Eq, Ord, 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 action handler = do
let expectedId = exceptionClassId $ cppExceptionInfo (undefined :: e)
catch action $ \caughtEx -> case caughtEx of
SomeCppException classInfo caughtFPtr caughtPtr ->
if expectedId == exceptionClassId (cppExceptionInfo UnknownCppException)
then do
case caughtFPtr of
Nothing -> exceptionClassDelete classInfo caughtPtr
Just _ -> return ()
handler $ unsafeCoerce UnknownCppException
else do
let maybeUpcastedPtr :: Maybe (Ptr ())
maybeUpcastedPtr =
if expectedId == exceptionClassId classInfo
then Just caughtPtr
else case M.lookup expectedId $ exceptionClassUpcasts classInfo of
Just upcast -> Just $ upcast caughtPtr
Nothing -> Nothing
case maybeUpcastedPtr of
Just upcastedPtr -> handler =<< case caughtFPtr of
Just fptr -> return $ cppExceptionBuild fptr upcastedPtr
Nothing -> cppExceptionBuildToGc upcastedPtr
Nothing -> throwIO caughtEx
SomeUnknownCppException ->
if expectedId == exceptionClassId (cppExceptionInfo UnknownCppException)
then handler $ unsafeCoerce UnknownCppException
else throwIO caughtEx
throwCpp :: CppThrowable e => e -> IO a
throwCpp = throwIO . toSomeCppException
data UnknownCppException = UnknownCppException
instance CppException UnknownCppException where
cppExceptionInfo _ = ExceptionClassInfo
{ exceptionClassId = ExceptionId 1
, exceptionClassName = "<Unknown C++ exception>"
, exceptionClassUpcasts = M.empty
, exceptionClassDelete = error "UnknownCppException.exceptionClassDelete: Should not get here."
, exceptionClassCopy = error "UnknownCppException.exceptionClassCopy: Should not get here."
, exceptionClassToGc = error "UnknownCppException.exceptionClassToGc: Should not get here."
}
cppExceptionBuild _ _ =
error "Internal error: cppExceptionBuild called for UnknownCppException"
cppExceptionBuildToGc _ =
error "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 info _ _) =
"<SomeCppException " ++ exceptionClassName info ++ ">"
show SomeUnknownCppException =
exceptionClassName $ cppExceptionInfo (undefined :: UnknownCppException)
internalHandleExceptions :: ExceptionDb -> (Ptr CInt -> Ptr (Ptr ()) -> IO a) -> IO a
internalHandleExceptions (ExceptionDb db) f =
alloca $ \excIdPtr ->
alloca $ \excPtrPtr -> do
result <- f excIdPtr excPtrPtr
excId <- peek excIdPtr
case excId of
0 -> return result
1 -> throwIO SomeUnknownCppException
_ -> do excPtr <- peek excPtrPtr
case M.lookup (ExceptionId excId) db of
Just info -> do
fptr <- exceptionClassToGc info excPtr
throwIO $ SomeCppException info (Just fptr) excPtr
Nothing ->
fail $
"internalHandleExceptions: Received C++ exception with unknown exception ID " ++
show excId ++ "."
internalHandleCallbackExceptions :: CppDefault a => Ptr CInt -> Ptr (Ptr ()) -> IO a -> IO a
internalHandleCallbackExceptions excIdPtr excPtrPtr doCall = do
poke excIdPtr 0
catch doCall $ \caughtEx -> case caughtEx of
SomeCppException classInfo caughtFPtr caughtPtr -> do
let ExceptionId excId = exceptionClassId classInfo
poke excIdPtr excId
poke excPtrPtr =<< case caughtFPtr of
Just fptr -> do
copiedPtr <- exceptionClassCopy classInfo caughtPtr
touchForeignPtr fptr
return copiedPtr
Nothing -> return caughtPtr
return cppDefault
SomeUnknownCppException ->
fail "Can't propagate unknown C++ exception from Haskell to C++."
newtype ExceptionDb = ExceptionDb (Map ExceptionId ExceptionClassInfo)
data ExceptionClassInfo = ExceptionClassInfo
{ exceptionClassId :: ExceptionId
, exceptionClassName :: String
, exceptionClassUpcasts :: Map ExceptionId (Ptr () -> Ptr ())
, exceptionClassDelete :: Ptr () -> IO ()
, exceptionClassCopy :: Ptr () -> IO (Ptr ())
, 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 ())
freeHaskellFunPtrFunPtr =
unsafePerformIO $ newFreeHaskellFunPtrFunPtr freeHaskellFunPtr
class CppDefault a where
cppDefault :: a
instance CppDefault () where cppDefault = ()
instance CppDefault CBool where cppDefault = 0
instance CppDefault CChar where cppDefault = 0
instance CppDefault CUChar where cppDefault = 0
instance CppDefault CShort where cppDefault = 0
instance CppDefault CUShort where cppDefault = 0
instance CppDefault CInt where cppDefault = 0
instance CppDefault CUInt where cppDefault = 0
instance CppDefault CLong where cppDefault = 0
instance CppDefault CULong where cppDefault = 0
instance CppDefault CLLong where cppDefault = 0
instance CppDefault CULLong where cppDefault = 0
instance CppDefault CFloat where cppDefault = 0
instance CppDefault CDouble where cppDefault = 0
instance CppDefault Int8 where cppDefault = 0
instance CppDefault Int16 where cppDefault = 0
instance CppDefault Int32 where cppDefault = 0
instance CppDefault Int64 where cppDefault = 0
instance CppDefault Word8 where cppDefault = 0
instance CppDefault Word16 where cppDefault = 0
instance CppDefault Word32 where cppDefault = 0
instance CppDefault Word64 where cppDefault = 0
instance CppDefault CPtrdiff where cppDefault = 0
instance CppDefault CSize where cppDefault = 0
instance CppDefault CSsize where cppDefault = 0
instance CppDefault (Ptr a) where cppDefault = nullPtr