hoppy-runtime 0.2.1 → 0.3.0

raw patch · 2 files changed

+269/−12 lines, 2 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• hoppy-runtime.cabal +6/−2
• src/Foreign/Hoppy/Runtime.hs +263/−10

@@ -1,5 +1,5 @@ name: hoppy-runtime-version: 0.2.1+version: 0.3.0 synopsis: C++ FFI generator - Runtime support homepage: http://khumba.net/projects/hoppy license: Apache-2.0@@ -20,12 +20,16 @@   exposed-modules:       Foreign.Hoppy.Runtime   default-extensions:-      FlexibleInstances+      DeriveDataTypeable+    , ExistentialQuantification+    , FlexibleInstances     , FunctionalDependencies     , GeneralizedNewtypeDeriving     , MultiParamTypeClasses+    , ScopedTypeVariables   build-depends:       base >=4.7 && <5+    , containers >=0.5 && <0.6   hs-source-dirs: src   ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind   default-language: Haskell2010

@@ -26,25 +26,52 @@   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 (bracket)+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 (FunPtr, Ptr, Storable, freeHaskellFunPtr, peek, poke)+import Foreign (+  ForeignPtr,+  FunPtr,+  Ptr,+  Storable,+  alloca,+  freeHaskellFunPtr,+  nullPtr,+  peek,+  poke,+  touchForeignPtr,+  ) import Foreign.C (   CChar,   CDouble,@@ -63,6 +90,7 @@   ) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types (CSsize)+import Unsafe.Coerce (unsafeCoerce)  foreign import ccall "wrapper" newFreeHaskellFunPtrFunPtr   :: (FunPtr (IO ()) -> IO ())@@ -106,24 +134,24 @@   nullptr :: this    -- | Runs an IO action on the 'Ptr' underlying this pointer.  Equivalent to-  -- 'Foreign.ForeignPtr.withForeignPtr' for managed pointers: the 'Ptr' is only+  -- 'ForeignPtr.withForeignPtr' for managed pointers: the 'Ptr' is only   -- guaranteed to be valid until the action returns.  There is no such   -- restriction for unmanaged pointers.   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-  -- 'Foreign.ForeignPtr.Unsafe.unsafeForeignPtrToPtr', namely that the object-  -- may be collected immediately after this function returns unless there is a+  -- '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 'Foreign.ForeignPtr.touchForeignPtr' for managed object-  -- pointers.  Has no effect on unmanaged pointers.+  -- | Equivalent to 'ForeignPtr.touchForeignPtr' for managed object pointers.+  -- Has no effect on unmanaged pointers.   touchCppPtr :: this -> IO () --- | C++ values that can be deleted.  All C++ classes bound by Hoppy have--- instances of @Deletable@.+-- | 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 ()@@ -161,6 +189,14 @@ instance Storable a => Assignable (Ptr a) a where   assign = 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@@ -268,10 +304,195 @@ withCppObj x = bracket (encode x) delete  -- | @withScopedPtr m f@ runs @m@ to get a pointer, which is given to @f@ to--- execute.  When @f@ finishes, the pointer is deleted.+-- execute.  When @f@ finishes, the pointer is deleted (via 'bracket'). withScopedPtr :: Deletable cppPtrType => IO cppPtrType -> (cppPtrType -> IO a) -> IO a withScopedPtr p = bracket p 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').  This+-- is useful in conjunction with function pointers created via generated+-- callback functions.+withScopedFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b+withScopedFunPtr p = bracket p freeHaskellFunPtr++-- | A unique identifier for a C++ class.  The representation is internal to+-- Hoppy.+newtype ExceptionId = ExceptionId CInt+                    deriving (Eq, Ord, 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 an object handle from a GC-managed object's raw+  -- pointers.+  cppExceptionBuild :: ForeignPtr () -> Ptr () -> e++  -- | Internal.  Constructs a GC-managed object 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 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+        -- 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 caughtFPtr of+          Nothing -> exceptionClassDelete classInfo caughtPtr+          Just _ -> return ()++        -- UnknownCppException is the only type with ID 1, so e ~ UnknownCppException.+        handler $ unsafeCoerce UnknownCppException++      else do+        -- Attempt to get a pointer for the type we're hoping to catch.+        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++        -- Call the handler, ensuring that the handle we pass is GCed.+        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  -- Same as above, this is safe.+      else throwIO 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 = throwIO . 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 _ = ExceptionClassInfo+    { exceptionClassId = ExceptionId 1+    , exceptionClassName = "<Unhandled 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"++-- | 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 info _ _) =+    "<SomeCppException " ++ exceptionClassName info ++ ">"+  show SomeUnknownCppException =+    exceptionClassName $ cppExceptionInfo (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 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 ++ "."++-- | 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 excIdPtr excPtrPtr doCall = do+  -- Indicate no exception unless we catch something.+  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++."++-- | 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+  { exceptionClassId :: ExceptionId+  , exceptionClassName :: String+  , exceptionClassUpcasts :: Map ExceptionId (Ptr () -> Ptr ())+    -- ^ This maps ancestor classes' exception IDs to functions that cast+    -- pointers from the current type to the ancestor type.+  , exceptionClassDelete :: Ptr () -> IO ()+    -- ^ Deletes the object.+  , exceptionClassCopy :: Ptr () -> IO (Ptr ())+    -- ^ Invokes the object's copy constructor.+  , 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@@ -318,3 +539,35 @@ {-# NOINLINE freeHaskellFunPtrFunPtr #-} freeHaskellFunPtrFunPtr =   unsafePerformIO $ newFreeHaskellFunPtrFunPtr freeHaskellFunPtr++-- | Internal.  Provides default values.+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