-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Runtime support for generated Haskell bindings.
module Foreign.Hoppy.Runtime (
  -- * Primitive types
  coerceIntegral,
  -- * Enumerations
  CppEnum (..),
  -- * Objects
  CppPtr (..),
  Deletable (..),
  Assignable (..),
  Copyable (..),
  Encodable (..),
  encodeAs,
  Decodable (..),
  decodeAndDelete,
  withCppObj,
  withScopedPtr,
  withScopedFunPtr,
  -- * Exceptions
  CppException (..),
  CppThrowable (..),
  catchCpp,
  throwCpp,
  UnknownCppException,
  -- * Containers
  HasContents (..),
  FromContents (..),
  -- * Internal
  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 ()))

-- | Converts between integral types by going from @a@ to @b@, and also
-- round-tripping the @b@ value back to an @a@ value.  If the two @a@ values
-- don't match, then an error is signalled.
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]
"."

-- | An instance @e@ of this class represents a value belonging to a C++
-- enumeration with numeric type @n@.
class CppEnum n e | e -> n where
  -- | Converts a number into an enum value.
  --
  -- If the Hoppy binding didn't request that the enum support arbitrary unknown
  -- values, then given an entry not explicitly supported by the enum, this
  -- throws an exception.
  toCppEnum :: HasCallStack => n -> e

  -- | Extracts the number that an enum value represents.
  fromCppEnum :: e -> n

-- | An instance of this class represents a handle (a pointer) to a C++ object.
-- All C++ classes bound by Hoppy have instances of @CppPtr@.  The lifetime of
-- such an object can optionally be managed by the Haskell garbage collector.
-- Handles returned from constructors are unmanaged, and 'toGc' converts an
-- unmanaged handle to a managed one.  'delete' must not be called on managed
-- handles.
class CppPtr this where
  -- | Polymorphic null pointer handle.
  nullptr :: this

  -- | Runs an IO action on the 'Ptr' underlying this handle.  Equivalent to
  -- 'ForeignPtr.withForeignPtr' for managed handles: the 'Ptr' is only
  -- guaranteed to be valid until the action returns.  There is no such
  -- restriction for unmanaged handles, but of course the object must still be
  -- alive to be used.
  withCppPtr :: this -> (Ptr this -> IO a) -> IO a

  -- | Converts to a regular pointer.  For objects managed by the garbage
  -- collector, this comes with the warnings associated with
  -- 'ForeignPtr.Unsafe.unsafeForeignPtrToPtr', namely that the object may be
  -- collected immediately after this function returns unless there is a
  -- 'touchCppPtr' call later on.
  toPtr :: this -> Ptr this

  -- | Equivalent to 'ForeignPtr.touchForeignPtr' for managed handles.  Has no
  -- effect on unmanaged handles.
  touchCppPtr :: this -> IO ()

-- | C++ values that can be deleted.  By default, C++ classes bound by Hoppy are
-- assumed to be deletable, so they get instances of @Deletable@.
class Deletable this where
  -- | Deletes the object with the C++ @delete@ operator.
  delete :: this -> IO ()

  -- | Converts a handle to one managed by the garbage collector.  A __new__
  -- managed handle is returned, and existing handles __including__ the
  -- argument remain unmanaged, becoming invalid once all managed handles are
  -- unreachable.  Calling this on an already managed handle has no effect and
  -- the argument is simply returned.  It is no longer safe to call 'delete' on
  -- the given object after calling this function.  It is also not safe to call
  -- this function on unmanaged handles for a single object multiple times: the
  -- object will get deleted more than once.
  --
  -- Up- and downcasting managed handles keeps the object alive correctly.
  toGc :: this -> IO this

-- | A typeclass for references to C++ values that can be assigned to.  This
-- includes raw pointers ('Ptr'), as well as handles for object types that have
-- an assignment operator (see
-- 'Foreign.Hoppy.Generator.Spec.ClassFeature.Assignable').
class Assignable cppType value where
  -- | @assign x v@ assigns the value @v@ at the location pointed to by @x@.
  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

-- | A typeclass for creating copies of C++ objects.  Every C++ class with a
-- copy constructor will have two instances:
--
-- > instance Copyable Foo Foo
-- > instance Copyable FooConst Foo
class Copyable from to | from -> to where
  copy :: from -> IO to

-- | For a C++ class that also has a native Haskell representation (e.g. value
-- types such as @std::string@), this typeclass allows converting a Haskell
-- value into a C++ object on the heap.  Encoding to both the non-const and
-- const objects is supported.
--
-- Because the functional dependency points in the direction it does, calls of
-- the form @'encode' value@ are ambiguously typed, so 'encodeAs' is provided to
-- resolve the ambiguity.
--
-- Prefer 'withCppObj' over calling 'encode' directly, to manage the lifetime of
-- the object.
--
-- See also 'Decodable'.
class Encodable cppPtrType hsType | cppPtrType -> hsType where
  encode :: hsType -> IO cppPtrType

-- | Takes a dummy argument to help with type resolution of 'encode', a la
-- 'asTypeOf'.  For example, for a handle type @StdString@ that gets converted
-- to a regular haskell 'String', the expected usage is:
--
-- > str :: String
-- > encodeAs (undefined :: StdString) str
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

-- | A typeclass for converting references to C++ values into Haskell values.
-- What this means depends on the type of C++ value.  Pointers to numeric types
-- and to other pointers (i.e. @'Ptr' ('Ptr' ...)@) are decodable by peeking at
-- the value.
--
-- For a C++ class that also has a native Haskell representation (e.g. value
-- types such as @std::string@), this typeclass allows converting a C++ heap
-- object into a Haskell value based on the defined conversion.  Decoding from
-- both the non-const and const objects is supported.
--
-- See also 'Encodable'.
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

-- | Decodes a C++ object to a Haskell value with 'decode', releases the
-- original object with 'delete', then returns the Haskell value.
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

-- | Temporarily encodes the Haskell value into a C++ object and passes it to
-- the given function.  When the function finishes, the C++ object is deleted.
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 m f@ runs @m@ to get a handle, which is given to @f@ to
-- execute.  When @f@ finishes, the handle is deleted (via 'bracket' and
-- '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 m f@ runs @m@ to get a 'FunPtr', which is given to @f@ to
-- execute.  When @f@ finishes, the 'FunPtr' is deleted (via 'bracket' and
-- 'freeHaskellFunPtr').  This is useful in conjunction with function pointers
-- created via generated callback functions.
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

-- | A unique identifier for a C++ class.  The representation is internal to
-- Hoppy.
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)

-- | A typeclass for C++ values that are catchable as exceptions.  C++ classes that
-- have been declared to be used as exceptions have instances of this class.
-- Unlike 'CppThrowable', 'UnknownCppException' is also an instance of this
-- typeclass.
class CppException e where
  -- | Internal.  Returns metadata about the exception.
  cppExceptionInfo :: e -> ExceptionClassInfo

  -- | Internal.  Constructs a handle from a GC-managed object's raw pointers.
  cppExceptionBuild :: ForeignPtr () -> Ptr () -> e

  -- | Internal.  Constructs a GC-managed handle from an unmanaged raw pointer.
  cppExceptionBuildToGc :: Ptr () -> IO e

-- | A typeclass for C++ values that are throwable as exceptions.  C++ classes that
-- have been declared to be used as exceptions have instances of this class.
class CppException e => CppThrowable e where
  -- | Internal.  Creates a 'throw'able exception from a C++ handle.
  toSomeCppException :: e -> SomeCppException

-- | Catches a C++ exception, similar to 'catch'.  Catching an exception class
-- will also catch subtypes of the class, per normal C++ exception semantics.
-- Catching 'UnknownCppException' will catch all C++ exceptions, but will
-- provide no information about the caught exception.  Exceptions caught with
-- this function are GC-managed heap objects; you do not need to manually delete
-- them.
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
        -- We're catching the top-level exception type, so we're done with the
        -- actual exception object.  If it's not garbage collected, delete it.
        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 ()

        -- UnknownCppException is the only type with ID 1, so e ~ UnknownCppException.
        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
        -- Attempt to get a pointer for the type we're hoping to catch.
        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

        -- Call the handler, ensuring that the handle we pass is GCed.
        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  -- Same as above, this is safe.
      else SomeCppException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeCppException
caughtEx

-- | Takes ownership of a C++ object, and throws it as a Haskell exception.
-- This can be caught in Haskell with 'catchCpp', or propagated to C++ when
-- within a callback that is marked as handling exceptions.
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

-- | A top type for C++ exceptions.  Catching this type with 'catchCpp' will
-- catch all C++ exceptions.  (You still have to declare what exceptions can be
-- thrown from each function, to make exceptions pass through the gateway
-- properly.)
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"

-- | Internal.  Holds an arbitrary 'CppException'.
--
-- Do not catch this with 'catch'; this can leak exception objects.  Always use
-- 'catchCpp' to catch C++ exceptions.
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)

-- | Internal.  Wraps a call to a C++ gateway function, and provides propagation
-- of C++ exceptions to Haskell.
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]
"."

-- | Internal.  Wraps a call to a Haskell function while invoking a callback,
-- and provides propagation of C++ exceptions back into C++.
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
  -- Indicate no exception unless we catch something.
  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++."

-- | Internal.  A database of information about exceptions an interface uses.
newtype ExceptionDb = ExceptionDb (Map ExceptionId ExceptionClassInfo)

-- | Internal.  Information about a C++ exception class.
data ExceptionClassInfo = ExceptionClassInfo
  { ExceptionClassInfo -> ExceptionId
exceptionClassId :: ExceptionId
  , ExceptionClassInfo -> [Char]
exceptionClassName :: String
  , ExceptionClassInfo -> Map ExceptionId (Ptr () -> Ptr ())
exceptionClassUpcasts :: Map ExceptionId (Ptr () -> Ptr ())
    -- ^ This maps ancestor classes' exception IDs to functions that cast
    -- pointers from the current type to the ancestor type.
  , ExceptionClassInfo -> Ptr () -> IO ()
exceptionClassDelete :: Ptr () -> IO ()
    -- ^ Deletes the object.
  , ExceptionClassInfo -> Ptr () -> IO (Ptr ())
exceptionClassCopy :: Ptr () -> IO (Ptr ())
    -- ^ Invokes the object's copy constructor.
  , ExceptionClassInfo -> Ptr () -> IO (ForeignPtr ())
exceptionClassToGc :: Ptr () -> IO (ForeignPtr ())
    -- ^ Assigns the object to the Haskell garbage collector, a la 'toGc'.
  }

-- | Containers whose contents can be convered to a list.
--
-- For a container @Cont@ holding values with C-side type @Foo@ and Haskell-side
-- type @Bar@, if the container uses 'Foreign.Hoppy.Generator.Std.ConvertPtr'
-- then the following instances are recommended:
--
-- > instance HasContents ContConst FooConst
-- > instance HasContents Cont Foo
--
-- If the container uses 'Foreign.Hoppy.Generator.Std.ConvertValue' then the
-- following instances are recommended:
--
-- > instance HasContents ContConst Bar
-- > instance HasContents Cont Bar
class HasContents c e | c -> e where
  -- | Extracts the contents of a container, returning the elements in a list.
  toContents :: c -> IO [e]

-- | Containers that can be created from a list.
--
-- For a container @Cont@ holding values with C-side type @Foo@ and Haskell-side
-- type @Bar@, if the container uses 'Foreign.Hoppy.Generator.Std.ConvertPtr'
-- then the following instance is recommended:
--
-- > instance FromContents Cont Foo
--
-- If the container uses 'Foreign.Hoppy.Generator.Std.ConvertValue' then the
-- following instance is recommended:
--
-- > instance HasContents Cont Bar
--
-- No instances for @ContConst@ are needed because it is easy enough to cast the
-- resulting collection to a const pointer.
class FromContents c e | c -> e where
  -- | Creates and returns a new container holding the given elements.
  fromContents :: [e] -> IO c

-- | Internal type that represents a pointer to a C++ callback object (callback
-- impl object, specifically).
newtype CCallback fnHsCType = CCallback (Ptr ())

-- | A global constant function pointer that points to 'freeHaskellFunPtr'.
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

-- | Internal.  Provides default values.
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