{-# OPTIONS_GHC -fglasgow-exts -XIncoherentInstances #-} -------------------------------------------------------------------- -- | -- Module : NET.Base -- Description : .NET bridge base functionality -- Copyright : (c) Sigbjorn Finne, 2008 -- License : BSD3 -- -- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- -- Primitive/low-level types and operations for the .NET bridge -- -------------------------------------------------------------------- module NET.Base where import Control.Monad import Data.Int import Data.Word import Numeric import Data.Char ( isSpace ) import Data.List ( intercalate ) import Data.Maybe import Foreign.C import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable import System.IO.Unsafe ( unsafePerformIO ) import Control.Exception as CE import Data.Typeable -- all for the benefit of 'allocBytes': import GHC.Ptr import GHC.Prim import GHC.Int import GHC.Base import GHC.IOBase infix 8 # infix 9 ## --type PrimObject = Ptr () type PrimObject = ForeignPtr () -- | @Object@ is the typed representation of a .NET -- object handle in Haskell. data Object a = Object PrimObject type NetObjFinalizer = Ptr () -> IO () --objRefToPtr x = x objRefToPtr x = unsafeForeignPtrToPtr x foreign import ccall "&DN_freeObject" theNetObjFinalizer :: FunPtr NetObjFinalizer --theNetObjFinalizer x = print x mkObject p = do -- print p fp <- newForeignPtr theNetObjFinalizer p return (Object fp) data Vector_ a type Vector a = Object (Vector_ a) tyVecArg :: Object (Vector_ a) -> a tyVecArg = undefined -- OO-style application operators: ( # ) :: a -> (a -> IO b) -> IO b obj # method = method obj ( ## ) :: IO a -> (a -> IO b) -> IO b mObj ## method = mObj >>= method -- value equality instance Eq (Object a) where (==) obj1 obj2 = unsafePerformIO $ obj1 # invokeMethod "Equals" (arg obj2) instance Show (Object a) where show obj1 = unsafePerformIO $ obj1 # invokeMethod "ToString" [] instance NetType a => Show (Vector a) where show obj1 = unsafePerformIO $ do -- t <- obj1 # invokeMethod "GetType" [] -- print "foo" ai <- createObj "System.Text.ASCIIEncoding" [] (ai :: Object ()) # invokeMethod "GetString" (arg obj1) -- obj1 # invokeMethod "ToCharArray" [] castObjTy :: Object a -> Object b castObjTy (Object o) = Object o objType :: Object a -> a objType = error "objType - not supposed to touch" isNullObj :: Object a -> Bool isNullObj (Object x) = objRefToPtr x == nullPtr -- -- Low-level and untyped marshalling of arguments and -- results are handled via the NetType class. User level -- -- type MarshalArg = Ptr (Ptr ()) -> IO () type InArg = (NETBridgeType, MarshalArg) type OutRes a = Ptr () -> IO a arg :: NetType a => a -> [InArg] arg v = arg_ v class NetType a where dotnetTy :: a -> NETBridgeType arg_ :: a -> [InArg] result :: Ptr () -> IO a instance NetType (Object a) where dotnetTy _ = Dotnet_Object arg_ (Object o) = [(Dotnet_Object, \ p -> poke p (castPtr (objRefToPtr o)))] result px = peek (castPtr px) >>= mkObject instance NetType a => NetType (Vector a) where dotnetTy v = Dotnet_Array (dotnetTy $ tyVecArg v) arg_ v@(Object o) = [( Dotnet_Array (dotnetTy $ tyVecArg v) , \ p -> poke p (castPtr (objRefToPtr o)) ) ] result px = peek (castPtr px) >>= mkObject instance NetType String where dotnetTy _ = Dotnet_String arg_ x = [(Dotnet_String,\ p -> withCString x $ \ px -> poke (castPtr p) px)] result px = do pv <- peek (castPtr px) if pv == nullPtr then return "" else do x <- peekCString pv free pv return x instance NetType Int where dotnetTy _ = Dotnet_Int32 arg_ x = [(Dotnet_Int32, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Int8 where dotnetTy _ = Dotnet_Int8 arg_ x = [(Dotnet_Int8, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Int16 where dotnetTy _ = Dotnet_Int16 arg_ x = [(Dotnet_Int16, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Int32 where dotnetTy _ = Dotnet_Int32 arg_ x = [(Dotnet_Int32, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Int64 where dotnetTy _ = Dotnet_Int64 arg_ x = [(Dotnet_Int64, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType () where dotnetTy _ = Dotnet_Unit arg_ x = [] result px = return () instance NetType Word where dotnetTy _ = Dotnet_Word32 arg_ x = [(Dotnet_Word32,\ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Word8 where dotnetTy _ = Dotnet_Word8 arg_ x = [(Dotnet_Word8,\ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Word16 where dotnetTy _ = Dotnet_Word16 arg_ x = [(Dotnet_Word16, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Word32 where dotnetTy _ = Dotnet_Word32 arg_ x = [(Dotnet_Word32, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Word64 where dotnetTy _ = Dotnet_Word64 arg_ x = [(Dotnet_Word64, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Bool where dotnetTy _ = Dotnet_Boolean arg_ x = [(Dotnet_Boolean, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Char where dotnetTy _ = Dotnet_Char arg_ x = [(Dotnet_Char, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Float where dotnetTy _ = Dotnet_Float arg_ x = [(Dotnet_Float,\ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance NetType Double where dotnetTy _ = Dotnet_Double arg_ x = [(Dotnet_Double, \ p -> poke (castPtr p) x)] result px = peek (castPtr px) instance (NetType a1, NetType a2) => NetType (a1,a2) where dotnetTy _ = Dotnet_Object arg_ (a1,a2) = (arg_ a1 ++ arg_ a2) result px = do o <- result (castPtr px) -- peek (castPtr px) return (o, undefined) -- Object (castPtr o)) instance (NetType a1, NetType a2, NetType a3) => NetType (a1,a2,a3) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3) = (arg_ a1 ++ arg_ a2 ++ arg_ a3) result px = do o <- result (castPtr px) return (o, undefined, undefined) instance (NetType a1, NetType a2, NetType a3, NetType a4) => NetType (a1,a2,a3,a4) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3,a4) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4) result px = do o <- result (castPtr px) return (o, undefined, undefined, undefined) instance (NetType a1, NetType a2, NetType a3, NetType a4, NetType a5) => NetType (a1,a2,a3,a4,a5) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3,a4,a5) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4 ++ arg_ a5) result px = do o <- result (castPtr px) return (o, undefined, undefined, undefined, undefined) instance (NetType a1, NetType a2, NetType a3, NetType a4, NetType a5, NetType a6) => NetType (a1,a2,a3,a4,a5,a6) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3,a4,a5,a6) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6) result px = do o <- result (castPtr px) return (o, undefined, undefined, undefined, undefined, undefined) instance (NetType a1, NetType a2, NetType a3, NetType a4, NetType a5, NetType a6, NetType a7) => NetType (a1,a2,a3,a4,a5,a6,a7) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3,a4,a5,a6,a7) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6 ++ arg_ a7) result px = do o <- result (castPtr px) return (o, undefined, undefined, undefined, undefined, undefined, undefined) instance (NetType a1, NetType a2, NetType a3, NetType a4, NetType a5, NetType a6, NetType a7, NetType a8) => NetType (a1,a2,a3,a4,a5,a6,a7,a8) where dotnetTy _ = Dotnet_Object arg_ (a1,a2,a3,a4,a5,a6,a7,a8) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6 ++ arg_ a7 ++ arg_ a8) result px = do o <- result (castPtr px) return (o, undefined, undefined, undefined, undefined, undefined, undefined, undefined) data NETBridgeType = Dotnet_Byte | Dotnet_Boolean | Dotnet_Char | Dotnet_Double | Dotnet_Float | Dotnet_Int | Dotnet_Int8 | Dotnet_Int16 | Dotnet_Int32 | Dotnet_Int64 | Dotnet_Word8 | Dotnet_Word16 | Dotnet_Word32 | Dotnet_Word64 | Dotnet_Ptr | Dotnet_Unit | Dotnet_Object | Dotnet_String | Dotnet_Array NETBridgeType deriving ( Eq, Show ) isVecType :: NETBridgeType -> Bool isVecType Dotnet_Array{} = True isVecType _ = False instance Enum NETBridgeType where toEnum x | x < 0 = Dotnet_Array (toEnum (-x)) | otherwise = case x of 0 -> Dotnet_Byte 1 -> Dotnet_Boolean 2 -> Dotnet_Char 3 -> Dotnet_Double 4 -> Dotnet_Float 5 -> Dotnet_Int 6 -> Dotnet_Int8 7 -> Dotnet_Int16 8 -> Dotnet_Int32 9 -> Dotnet_Int64 10 -> Dotnet_Word8 11 -> Dotnet_Word16 12 -> Dotnet_Word32 13 -> Dotnet_Word64 14 -> Dotnet_Ptr 15 -> Dotnet_Unit 16 -> Dotnet_Object 17 -> Dotnet_String _ -> error "toEnum/other: shouldn't happen" fromEnum x = case x of Dotnet_Array v -> -(fromEnum v) Dotnet_Byte -> 0 Dotnet_Boolean -> 1 Dotnet_Char -> 2 Dotnet_Double -> 3 Dotnet_Float -> 4 Dotnet_Int -> 5 Dotnet_Int8 -> 6 Dotnet_Int16 -> 7 Dotnet_Int32 -> 8 Dotnet_Int64 -> 9 Dotnet_Word8 -> 10 Dotnet_Word16 -> 11 Dotnet_Word32 -> 12 Dotnet_Word64 -> 13 Dotnet_Ptr -> 14 Dotnet_Unit -> 15 Dotnet_Object -> 16 Dotnet_String -> 17 toTyTag :: NETBridgeType -> [Char] toTyTag x = case x of Dotnet_Byte -> "By" Dotnet_Boolean -> "B" Dotnet_Char -> "C" Dotnet_Double -> "D" Dotnet_Float -> "F" Dotnet_Int -> "I" Dotnet_Int8 -> "I8" Dotnet_Int16 -> "I16" Dotnet_Int32 -> "I32" Dotnet_Int64 -> "I64" Dotnet_Word8 -> "W8" Dotnet_Word16 -> "W16" Dotnet_Word32 -> "W32" Dotnet_Word64 -> "W64" Dotnet_Ptr -> "P" Dotnet_Unit -> "()" Dotnet_Object -> "O" Dotnet_String -> "S" Dotnet_Array e -> "[]" ++ toTyTag e -- self-documenting type synonyms type ClassName = String type FieldName = String type MethodName = String invokeStaticMeth_ :: NetType a => String -> Bridge_Static_Signature -> ClassName -> MethodName -> [InArg] -> IO a invokeStaticMeth_ loc meth cName tyName args = let arity = length args in let cty = cName ++ (if null tyName then "" else '.':tyName) in withArgResult arity $ \ argVec res -> do setArgs argVec args withCString "" $ \ p_assem -> withCString cty $ \ p_ty -> do let hres = result (resPtr res) pd <- meth p_assem p_ty (argVecPtr argVec) (fromIntegral $ argSize argVec) (fromEnumI $ isVecType $ dotnetTy $ dotnetTyIO hres) (fromEnumI (resultType res)) (resPtr res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError (toNETError str){ netErrorSource = cty , netErrorMethodSig = Just (map fst args, dotnetTy $ dotnetTyIO hres) , netErrorLocation = loc } else hres dotnetTyIO :: (NetType a) => IO a -> a dotnetTyIO = undefined invokeStaticMethod :: NetType a => ClassName -> MethodName -> [InArg] -> IO a invokeStaticMethod = invokeStaticMeth_ "static-method" bridge_invokeStatic_ getFieldStaticB :: NetType a => ClassName -> FieldName -> [InArg] -> IO a getFieldStaticB = invokeStaticMeth_ "get-static" bridge_getStatic_ setFieldStaticB :: NetType a => ClassName -> FieldName -> [InArg] -> IO a setFieldStaticB = invokeStaticMeth_ "set-static" bridge_setStatic_ createObj :: NetType a => ClassName -> [InArg] -> IO a createObj cName args = invokeStaticMeth_ "NET.Base.createObject" bridge_createObject_ cName "" args invokeObjOp_ :: NetType a => String -> Bridge_Object_Signature -> MethodName -> [InArg] -> Object b -> IO a invokeObjOp_ loc meth methName args obj = let arity = 1+length args in withArgResult arity $ \ argVec res -> do -- print (methName) setArgs argVec (args ++ arg obj) withCString methName $ \ p_m -> do let hres = result (resPtr res) pd <- meth p_m (argVecPtr argVec) (fromIntegral $ argSize argVec) (fromEnumI $ isVecType $ dotnetTy $ dotnetTyIO hres) (fromEnumI (resultType res)) (resPtr res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError (toNETError str){ netErrorSource = methName , netErrorMethodSig = Just (map fst (args ++ arg obj),dotnetTy $ dotnetTyIO hres) , netErrorLocation = loc } else hres invokeMethod :: NetType a => MethodName -> [InArg] -> Object b -> IO a invokeMethod = invokeObjOp_ "method" bridge_invokeMethod_ getFieldB :: NetType a => FieldName -> [InArg] -> Object b -> IO a getFieldB = invokeObjOp_ "get-field" bridge_getField_ setFieldB :: NetType a => FieldName -> [InArg] -> Object b -> IO a setFieldB = invokeObjOp_ "set-field" bridge_setField_ resultType :: NetType a => ResultObj a -> NETBridgeType resultType x = dotnetTy (resType_hack x) resType_hack :: NetType a => ResultObj a -> a resType_hack = undefined fromEnumI x = fromIntegral (fromEnum x) newVector :: NetType a => NETBridgeType -> Int -> IO (Vector a) newVector ty x = do withResult $ \ p_res -> do pd <- bridge_mkVector_ (fromEnumI ty) (fromIntegral x) (resPtr p_res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError ((toNETError str){ netErrorSource = show ty , netErrorLocation = "newVector" }) else result (resPtr p_res) -- | @ArgVector@ is our representation of the argument list that -- we hand over to the bridge data ArgVector = ArgVector { argVecPtr :: Ptr () , argSize :: Int -- >= 0 } argEntrySize :: Int argEntrySize = argEntryValSize + sizeOf (undefined :: Int) + alignment (undefined::Int) argEntryValSize :: Int argEntryValSize = 8 newArgVector :: Int -> IO ArgVector newArgVector l = do p <- allocBytes (l * argEntrySize) return (ArgVector{argVecPtr=p, argSize=l}) withArgVector :: Int -> (ArgVector -> IO a) -> IO a withArgVector l k = allocaBytes (l * argEntrySize) $ \ p -> do let argVec = ArgVector{argVecPtr=p, argSize=l} k argVec setArg :: (Ptr a -> IO ()) -> ArgVector -> Int -> IO ArgVector setArg wr args p | p > argSize args = fail ("setArg: argument index out out range: " ++ show (p,argSize args)) | otherwise = do -- print (p, argVecPtr args, argVecPtr args `plusPtr` (p * argEntrySize)) wr (argVecPtr args `plusPtr` (p * argEntrySize)) return args allocBytes :: Int -> IO (Ptr ()) allocBytes (I# size) = IO $ \ s -> case newPinnedByteArray# size s of { (# s, mbarr# #) -> case unsafeFreezeByteArray# mbarr# s of { (# s, barr# #) -> let addr = Ptr (byteArrayContents# barr#) in -- ToDo: chase down semantics of this primop. possibly -- a no-op here. case touch# barr# s of { s1 -> (# s1, addr #) }}} newResult :: IO ArgVector newResult = newArgVector 1 newtype ResultObj a = ResultObj { resPtr :: Ptr () } withResult :: NetType a => (ResultObj a -> IO a) -> IO a withResult k = withArgVector 1 (\ p -> k (ResultObj (argVecPtr p))) withArgResult :: NetType a => Int -> (ArgVector -> ResultObj a -> IO a) -> IO a withArgResult l k = allocaBytes (l * argEntrySize) $ \ p -> do let argVec = ArgVector{argVecPtr=p, argSize=l} withResult $ k argVec boxStorable :: Storable a => a -> IO (Object a) boxStorable x = withArgVector 1 $ \ vec -> do setArg (\ p -> poke p x) vec 0 -- createObject "Int" a return undefined stringArg :: ArgVector -> Int -> String -> IO () stringArg a v s = do x <- newCString s setArg (\ p -> do poke p x pokeByteOff p 8 (fromEnum Dotnet_String)) a v return () setArgs :: ArgVector -> [InArg] -> IO () setArgs aVec args = zipWithM_ (\ (t,wrArg) i -> do setArg (\ p -> do wrArg p -- print (i,fromEnum t) pokeByteOff p 8 (fromEnum t)) aVec i) args [(0::Int)..] toNETError :: String -> NETError toNETError s = let ne = parseErrorString s in case isFailedOperation ne of False -> ne _ -> let desc | null (netErrorDescr ne) || netErrorDescr ne == "(null)" = "NET operation failed" | otherwise = netErrorDescr ne in ne{netErrorDescr=desc,netErrorKind=NETOpFailed} parseErrorString :: String -> NETError parseErrorString s = NETError { netErrorLocation = fromMaybe "unknown" $ l_s "Location" , netErrorKind = fromMaybe NETOtherError $ l_r "Code" , netErrorDescr = fromMaybe "" $ l_s "Description" , netErrorSource = fromMaybe "" $ l_s "Source" , netErrorMethodSig = Nothing } where ls = map toAssoc $ lines s toAssoc xs = case break (==':') xs of (as,':':bs) -> (as,dropWhile isSpace bs) (as,_) -> (as,"") l_s x = lookup x ls l_r x = readE $ lookup x ls readE Nothing = Nothing readE (Just ('0':'x':xs)) = case readHex xs of ((v,_):_) -> Just (NETCOMError v (l_s "CodeDescr")) _ -> Nothing readE (Just xs) = case reads xs of ((v,_):_) -> Just (NETErrorCode v) _ -> Nothing data NETError = NETError { netErrorLocation :: String , netErrorKind :: NETErrorKind , netErrorDescr :: String , netErrorSource :: String , netErrorMethodSig :: Maybe ([NETBridgeType],NETBridgeType) } deriving ( Typeable ) isFailedOperation :: NETError -> Bool isFailedOperation ne = case netErrorKind ne of NETCOMError 0x80004005 _ -> True -- E_FAIL NETCOMError 0x6 _ -> True -- ERROR_INVALID_HANDLE .. NETErrorCode 6 -> True -- ERROR_INVALID_HANDLE .. _ -> False showNETError :: NETError -> String showNETError ne = unlines ([ "NET bridge error:" , " Location: " ++ netErrorLocation ne , " Source: " ++ netErrorSource ne , " Kind: " ++ showNETErrorKind (netErrorKind ne) , " Description: " ++ netErrorDescr ne ] ++ case netErrorMethodSig ne of Just (args,res) -> [" Method type: " ++ toMethodSig args res] _ -> []) toMethodSig xs r = '(':(intercalate "," $ map toTyTag xs) ++ ")" ++ toTyTag r instance Show NETError where show x = showNETError x type HRESULT = Word32 data NETErrorKind = NETOtherError | NETOpFailed | NETCOMError HRESULT (Maybe String) | NETErrorCode Int showNETErrorKind :: NETErrorKind -> String showNETErrorKind n = case n of NETOtherError -> "HsNET bridge error" NETOpFailed -> "Operation failed" NETCOMError x mb -> "COM error: 0x" ++ showHex x (' ':maybe "" id mb) NETErrorCode x -> "HsNET error " ++ show x data SomeNETException = forall e . Exception e => SomeNETException e deriving Typeable instance Show SomeNETException where show (SomeNETException e) = show e instance Exception SomeNETException netToException :: Exception e => e -> SomeException netToException = toException . SomeNETException netFromException :: Exception e => SomeException -> Maybe e netFromException x = do SomeNETException a <- fromException x cast a instance Exception NETError where toException = netToException fromException = netFromException handleNET :: (NETError -> IO a) -> IO a -> IO a handleNET h e = catchNET e h tryNET :: IO a -> IO (Either NETError a) tryNET f = handleNET (\ x -> return (Left x)) (f >>= return.Right) throwNETError :: NETError -> IO a throwNETError e = throwIO e catchNET :: IO a -> (NETError -> IO a) -> IO a catchNET f hdlr = CE.catch f (\ e1 -> hdlr e1) -- something's badly wrong here having to pick out arbitrary args -- down the C stack! type DelegatorPrim_ = Ptr () -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> IO () type DelegatorPrim = Ptr () -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> IO (Ptr ()) type Delegator1Prim = Ptr () -> Ptr () -> Ptr () -> IO (Ptr ()) foreign import stdcall "wrapper" wrapDelegate_ :: DelegatorPrim_ -> IO (FunPtr DelegatorPrim_) foreign import stdcall "wrapper" wrapDelegate :: DelegatorPrim -> IO (FunPtr DelegatorPrim) foreign import stdcall "wrapper" wrapDelegate1 :: Delegator1Prim -> IO (FunPtr Delegator1Prim) newDelegator2_ :: String -> (Object a -> Object b -> IO ()) -> IO (Object ()) newDelegator2_ delTy fun = withCString delTy $ \ p_delTy -> withResult $ \ p_res -> do wr <- wrapDelegate_ (delegatorWrapper fun) pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError ((toNETError str){ netErrorSource=delTy , netErrorLocation="newDelegator" }) else result (resPtr p_res) where delegatorWrapper :: (Object a -> Object b -> IO ()) -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> IO () delegatorWrapper inner obj1 obj2 obj3 obj4 obj5 = do -- print ("del",obj1,obj2,obj3,obj4,obj5) p1 <- mkObject obj3 p2 <- mkObject obj5 -- print (p1,p2) inner p1 p2 newDelegator2 :: String -> (Object a -> Object b -> IO (Object c)) -> IO (Object ()) newDelegator2 delTy fun = withCString delTy $ \ p_delTy -> withResult $ \ p_res -> do wr <- wrapDelegate (delegatorWrapper fun) pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError ((toNETError str){ netErrorSource=delTy , netErrorLocation="newDelegator" }) else result (resPtr p_res) where delegatorWrapper :: (Object a -> Object b -> IO (Object c)) -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> Ptr () -> IO (Ptr ()) delegatorWrapper inner obj1 obj2 obj3 obj4 obj5 = do -- print ("del",obj1,obj2,obj3,obj4,obj5) p1 <- mkObject obj3 p2 <- mkObject obj5 -- print (p1,p2) (Object o) <- inner p1 p2 return (objRefToPtr o) newDelegator1 :: String -> (Object a -> IO (Object b)) -> IO (Object ()) newDelegator1 delTy fun = withCString delTy $ \ p_delTy -> withResult $ \ p_res -> do wr <- wrapDelegate1 (delegatorWrapper fun) pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res) if pd /= nullPtr then peekCString pd >>= \ str -> free pd >> throwNETError ((toNETError str){ netErrorSource=delTy , netErrorLocation="newDelegator1" }) else result (resPtr p_res) where delegatorWrapper :: (Object a -> IO (Object b)) -> Delegator1Prim delegatorWrapper inner obj1 obj2 obj3 = do -- print ("del",obj1,obj2,obj3,obj4,obj5) p1 <- mkObject obj3 -- print (p1,p2) (Object o) <- inner p1 return (objRefToPtr o) -- set to @True@ to enable stack trace dumps from the .NET side. setDumpExceptionsFlag :: Bool -> IO () setDumpExceptionsFlag flg = bridge_setDumpExceptionsFlag_ flg type Bridge_Static_Signature = CString -> CString -> Ptr () -> CInt -> CInt -> CInt -> Ptr () -> IO CString type Bridge_Object_Signature = CString -> Ptr () -> CInt -> CInt -> CInt -> Ptr () -> IO CString foreign import ccall "DN_invokeStatic" bridge_invokeStatic_ :: Bridge_Static_Signature foreign import ccall "DN_getStatic" bridge_getStatic_ :: Bridge_Static_Signature foreign import ccall "DN_setStatic" bridge_setStatic_ :: Bridge_Static_Signature foreign import ccall "DN_createObject" bridge_createObject_ :: Bridge_Static_Signature foreign import ccall "DN_invokeMethod" bridge_invokeMethod_ :: Bridge_Object_Signature foreign import ccall "DN_getField" bridge_getField_ :: Bridge_Object_Signature foreign import ccall "DN_setField" bridge_setField_ :: Bridge_Object_Signature foreign import ccall "DN_mkVector" bridge_mkVector_ :: CInt -> CInt -> Ptr () -> IO CString foreign import ccall "DN_defineDelegator" bridge_defineDelegator_ :: CString -> FunPtr () -> Ptr () -> IO CString foreign import ccall "DN_freeObject" bridge_freeObject_ :: Ptr () -> IO () foreign import ccall "DN_derefHandle" bridge_derefHandle_ :: Ptr () -> IO (Ptr ()) foreign import ccall "DN_setDumpExceptionsFlag" bridge_setDumpExceptionsFlag_ :: Bool -> IO ()