hdirect-0.21.0: comlib/ComServ.lhs
%
% (c) Sigbjorn Finne, 1998-99
%
Support code for writing Haskell COM components (yay!)
The library code for Haskell COM components (aka. servers),
support the wrapping up of a bunch of Haskell function values
into the binary representation that the COM spec mandates.
The library has two classes of 'users':
- HaskellDirect generated stubs for interfaces representing
Haskell COM components.
- on-the-fly generation of COM interface pointers by a Haskell
application.
i.e., in short, we care about having a simple, programmer-useable, API :-)
\begin{code}
{-# OPTIONS -#include "ComServ_stub.h" #-}
{-# OPTIONS -#include "comPrim.h" #-}
module ComServ
(
createComInstance -- :: String
-- -> objState
-- -> IO ()
-- -> [ComInterface objState]
-- -> IID iid
-- -> IO (IUnknown iid)
, createInstance -- :: objState
-- -> VTable iid objState
-- -> IO (IUnknown iid)
, createVTable -- :: [Ptr ()] -> IO (VTable iid objState)
-- prefixes the three IU methods.
, createComVTable -- :: [Ptr ()] -> IO (ComVTable iid objState)
, createIPointer -- :: StablePtr a
-- -> (VTable b)
-- -> IO (PrimIP b)
, cloneIPointer -- :: IUnknown a -> VTable b -> IO (PrimIP b)
, cloneIPointer_prim -- :: PrimIP a -> VTable b -> IO (PrimIP b)
, getObjState -- :: PrimIP a -> IO b
, getRealObjState -- :: PrimIP a -> IO b
, createDualInterface -- :: [Ptr ()]
-- -> IID iid
-- -> Either LIBID String
-- -> IUnknown a
-- -> IO (IDispatch ())
, createDispInterface -- :: IUnknown iid -- the interface to delegate to
-- -> Either LIBID String -- libid of type library to use.
-- -> IID iid
-- what interface it implements (needed to
-- get at the type library which drives
-- the dispatch interface.)
-- -> IO (IDispatch ())
-- the dispatch implementation handed back.
, VTable
, ComVTable
, PrimIP
, ComInterface
, mkIface
, mkDispIface
, mkDualIface
, export_getTypeInfoCount
, export_getTypeInfo
, export_getIDsOfNames
, export_invoke
) where
import HDirect
import Word
import Int
import IOExts
import Com hiding ( queryInterface, addRef, release )
import qualified Com ( addRef, release )
import Automation ( IDispatch, VARIANT, iidIDispatch, DISPID )
import Foreign.StablePtr
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Maybe ( fromMaybe )
import Bits ( (.&.) )
import ComException
import WideString
import Monad
import List
\end{code}
Basic types - we're essentially untyped here; safety is provided
by the abstraction levels above us.
\begin{code}
type PrimIP iid = Ptr (Ptr ())
type VTBL = (Ptr (Ptr ()), Int)
type VTable iid objState = VTBL
type ComVTable iid objState = VTable iid (objState, IUnkState)
data ComInterface objState
= Iface { ifaceGUID :: GUID
, ifaceVTBL :: VTBL
}
| DispIface { ifaceGUID :: GUID
, ifaceLIBID :: Either LIBID String
, ifaceVTBL :: VTBL
, isDual :: Bool
}
mkIface :: IID iid -> VTable iid objState -> ComInterface objState
mkIface iid a = Iface (iidToGUID iid) a
mkDispIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
mkDispIface l iid v = DispIface (iidToGUID iid) l' v False
where
l' = fromMaybe (Right "") (fmap Left l)
mkDualIface :: Maybe LIBID -> IID iid -> VTable iid objState -> ComInterface objState
mkDualIface l iid v = DispIface (iidToGUID iid) l' v True
where
l' = fromMaybe (Right "") (fmap Left l)
\end{code}
=== Creating a component instance ===
`createComInstance' creates a new COM component instance, given
the initial state together with the (implementation) of the
interfaces that the component supports. The interface pointer
that it returns is at the one requested.
\begin{code}
createComInstance :: String -- DLL path.
-> objState -- initial state
-> IO () -- action to perform when releasing object.
-> [ComInterface objState] -- supported interfaces
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createComInstance dll_path initState releaseAction supported_ifaces initial_iid = do
ip_state <- mkInstanceState supported_ifaces dll_path releaseAction initState
(_,iu) <- deRefStablePtr ip_state
res <- lookupInterface initial_iid (iu_ifaces iu)
case res of
(_,_,ip) -> do
-- putMessage ("createComInstance: " ++ show initial_iid)
return (castIface ip)
createInstance :: objState -> VTable (IUnknown iid) objState -> IO (IUnknown iid)
createInstance initState vtable = do
ip_state <- newStablePtr initState
createIPointer ip_state vtable
\end{code}
=== Creating the component instance specific state ===
Internal function which allocates an (immovable) chunk of
memory which holds the instance-specific state of a component.
For each component instance we keep a stable pointer to the
component instance state. In all likelihood, this object state
also contains enough information for the <tt/IUnknown/ methods
to operate correctly.
\begin{code}
createIPointer :: StablePtr a
-> VTBL
-> IO (IUnknown b)
createIPointer iface_st (vtbl,_) = do
pre <- alloc (sizeofIfaceHeader)
poke pre vtbl
poke (pre `plusPtr` fromIntegral sizeofPtr) iface_st
-- writeAddrOffAddr pre 0 vtbl
-- writeStablePtrOffAddr pre 1 iface_st
unmarshallIUnknown False{-finalise-} pre
sizeofIfaceHeader :: Word32 -- in bytes.
sizeofIfaceHeader =
sizeofPtr -- lpVtbl
+ sizeofPtr -- interface pointer state
-- for convenience.
cloneIPointer :: IUnknown iid_old -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
cloneIPointer iptr vtbl = do
stable_state <- getIPointerState_stbl (ifaceToAddr iptr)
createIPointer stable_state vtbl
cloneIPointer_prim :: Ptr (IUnknown a) -> VTable (IUnknown iid_new) objState -> IO (IUnknown iid_new)
cloneIPointer_prim iptr vtbl = do
stable_state <- getIPointerState_stbl iptr
createIPointer stable_state vtbl
\end{code}
<tt/findInterface/ is used by both the class factory
and <tt/queryInterface/ to check whether the component
implements a particular interface.
\begin{code}
findInterface :: IUnkIfaceInfo
-> Ptr GUID
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
findInterface ls piid ppv = do
iid <- unmarshallGUID False piid
if (iid == iidToGUID iidIUnknown) then
case ls of
[] -> return e_NOINTERFACE
((_,_,ip):_) -> realiseIPointer ip
else if (iid == iidToGUID iidIDispatch) then
case filter (isIDispatch) ls of
[] -> return e_NOINTERFACE
((_,_,ip):_) -> realiseIPointer ip
else
let
findIt [] = do
poke (castPtr ppv) nullPtr
return e_NOINTERFACE
findIt ((x,_,ip):xs)
| x == iid = realiseIPointer ip
| otherwise = findIt xs
in
findIt ls
where
-- 'realiseIPointer' fills in the [out] ptr and return.
-- This has the desired effect of forcing the evaluation
-- of the interface pointer itself.
realiseIPointer newip = do
primip <- marshallIUnknown newip
writefptr ppv primip
-- writeForeignObj ppv primip
addRef (ifaceToAddr newip)
return s_OK
--
-- Note: there's currently no way of indicating that
-- an interface IA (which derives from IDispatch) has
-- a 'idispatch' nature here other than go via the
-- route of using the tlb marshaller.
--
isIDispatch (iid, flg, _) = flg || iid == iidToGUID iidIDispatch
lookupInterface :: IID iid
-> IUnkIfaceInfo -- [(GUID, Bool, IUnknown ())]
-> IO (GUID, Bool, IUnknown ())
lookupInterface iid [] = ioError (userError "lookupInterface: interface not supported")
lookupInterface iid ls@(i:_) =
case (find (\ (i,_,_) -> i == guid) ls) of
Nothing -> return i
Just i -> return i
where
guid = iidToGUID iid
\end{code}
\begin{code}
data IUnkState
= IUnkState
{ iu_ifaces :: IUnkIfaceInfo
, iu_release :: IO ()
, iu_refcnt :: IORef Int
}
type IUnkIfaceInfo = [(GUID, Bool, IUnknown ())]
mkInstanceState :: [ComInterface objState]
-> String
-> IO ()
-> objState
-> IO (StablePtr (objState, IUnkState))
mkInstanceState iface_list dll_path releaseAction objState = do
fixIO (\ stbl_st -> do
ref_cnt <- newIORef 1
let iptrs = map (mkIf stbl_st) iface_list
iu_st = IUnkState iptrs releaseAction ref_cnt
newStablePtr (objState, iu_st)
)
where
mkIf st (Iface iid vtbl) =
(iid, False, unsafePerformIO (createIPointer st vtbl))
mkIf st (DispIface guid libid vtbl is_dual) =
(guid, True, unsafePerformIO $ do
let iid = guidToIID guid
lib_loc =
case libid of
Right "" -> Right dll_path
_ -> libid
if is_dual then
createDualInterface st vtbl lib_loc iid
else do
ip <- createIPointer st vtbl
createDispInterface ip lib_loc iid
)
\end{code}
'Standard' IUnknown implementation:
Implementation assumes that the object state is of
the form :
StablePtr ((real_obj_state::a), (iu_state :: IUnkState))
(which it is if 'createCoClass' was used to create the component
instance.)
\begin{code}
queryInterface :: Ptr (IUnknown a)
-> Ptr GUID
-> Ptr (Ptr (IUnknown b))
-> IO HRESULT
queryInterface iptr riid ppvObject = do
iid <- unmarshallGUID False riid
-- putMessage ("qi: " ++ show (iptr,iid))
if_ls <- getSupportedInterfaces iptr
hr <- findInterface if_ls riid ppvObject
-- putMessage ("qi: " ++ show (iid,hr))
return hr
addRef :: Ptr (IUnknown a) -> IO Word32
addRef iptr = do
-- putMessage "addRef"
v <- readRefCount iptr
writeRefCount iptr (v+1)
return (fromIntegral v)
release :: Ptr (IUnknown a) -> IO Word32
release iptr = do
-- putMessage ("release: " ++ show iptr)
v <- readRefCount iptr
-- putMessage ("release: " ++ show (iptr,v))
let v' = v-1
writeRefCount iptr v'
if v' <= 0 then do
releaseObj iptr
let x = (fromIntegral 0)
return x
else do
let x = (fromIntegral (v-1))
return x
\end{code}
\begin{code}
foreign export stdcall dynamic export_queryInterface :: (Ptr (IUnknown a) -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO Int32) -> IO (Ptr ())
foreign export stdcall dynamic export_addRef :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr ())
foreign export stdcall dynamic export_release :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr ())
\end{code}
\begin{code}
releaseObj :: Ptr (IUnknown a) -> IO ()
releaseObj iptr = do
-- putMessage "releaseObj"
-- * invoke user-supplied finaliser.
r <- iptr # getReleaseAction
r
-- * free up mem allocated to hold interface pointers (and vtbls?).
-- * free embedded stable pointers.
stbl <- iptr # getIPointerState_stbl
freeStablePtr stbl
-- and the GC will take care of the rest..
return ()
\end{code}
Accessing data accessible via a Haskell i-pointer - this stuff
\begin{code}
readRefCount :: Ptr (IUnknown a) -> IO Int
readRefCount ptr = do
iu <- getIUnkState ptr
readIORef (iu_refcnt iu)
writeRefCount :: Ptr (IUnknown a) -> Int -> IO ()
writeRefCount ptr v = do
iu <- getIUnkState ptr
writeIORef (iu_refcnt iu) v
getReleaseAction :: Ptr (IUnknown a) -> IO (IO ())
getReleaseAction ptr = do
iu <- getIUnkState ptr
return (iu_release iu)
getSupportedInterfaces :: Ptr (IUnknown a) -> IO IUnkIfaceInfo
getSupportedInterfaces ptr = do
iu_state <- getIUnkState ptr
return (iu_ifaces iu_state)
getIUnkState :: Ptr (IUnknown a) -> IO IUnkState
getIUnkState iptr = do
stbl <- getIPointerState_stbl iptr
(_,x) <- deRefStablePtr stbl
return x
-- users of 'createCoClass' *must* use this and not
-- the one below!
getObjState :: Ptr (IUnknown a) -> IO b
getObjState iptr = do
stbl <- getIPointerState_stbl iptr
(x,_) <- deRefStablePtr stbl
return x
getRealObjState :: Ptr (IUnknown a) -> IO b
getRealObjState iptr = do
stbl <- getIPointerState_stbl iptr
deRefStablePtr stbl
getIPointerState_stbl :: Ptr (IUnknown a) -> IO (StablePtr b)
getIPointerState_stbl iptr = peek (iptr `plusPtr` fromIntegral sizeofPtr)
--readStablePtrOffAddr iptr 1
\end{code}
Dispatch interface support:
\begin{code}
createDualInterface :: StablePtr objState
-> ComVTable (IUnknown iid) objState
-> Either LIBID String
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createDualInterface ip_state vtbl libid iid = do
ip <- createIPointer ip_state vtbl
st <- mkDispatchState libid ip iid
meths <- unmarshallVTable vtbl
let real_meths =
case meths of
(qi : ar : re : ls) -> ls
_ -> error "createDualInterface: failed to strip of IU methods"
vtable <- createDispVTable real_meths st
cloneIPointer ip vtable
createDispInterface :: IUnknown iid -- the interface to delegate to
-> Either LIBID String
-- libid of type library to use / path to where the .tlb is stored.
-> IID (IUnknown iid)
-- what interface it implements (needed to
-- get at the type library which drives
-- the dispatch interface.)
-> IO (IUnknown iid)
-- the dispatch implementation handed back.
createDispInterface ip libid iid = do
-- putMessage ("createDispInterface: " ++ show (libid, iid))
st <- mkDispatchState libid ip iid
-- putMessage ("createDispInterface: " ++ show (libid, iid))
vtable <- createDispVTable [] st
-- putMessage ("createDispInterface: " ++ show (libid, iid))
i <- cloneIPointer ip vtable
-- putMessage ("createDispInterface: " ++ show (libid, iid))
return i
mkDispatchState :: Either LIBID String
-> IUnknown iid
-> IID (IUnknown iid)
-> IO DispState
mkDispatchState libid ip iid = do
pTInfo_ref <- newIORef nullPtr
return (DispState libid (coerceIID iid) (coerceIP ip) pTInfo_ref)
--sigh.
coerceIID :: IID a -> IID b
coerceIID iid = guidToIID (iidToGUID iid)
coerceIP :: IUnknown a -> IUnknown b
coerceIP x = castIface x
data DispState
= DispState {
disp_libid :: Either LIBID String,
disp_iid :: (IID ()),
disp_ip :: (IUnknown ()),
disp_ti :: (IORef (PrimIP (ITypeInfo ())))
}
type DISPPARAMS = Ptr () -- abstract, really.
type EXCEPINFO = Ptr () -- abstract, really.
createDispVTable :: [Ptr ()]
-> DispState
-> IO (ComVTable (IDispatch ()) DispState)
createDispVTable meths disp_st = do
a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount
a_getTypeInfo <- export_getTypeInfo (getTypeInfo disp_st)
a_getIDsOfNames <- export_getIDsOfNames (getIDsOfNames disp_st)
a_invoke <- export_invoke (invoke disp_st)
createComVTable ([ a_getTypeInfoCount
, a_getTypeInfo
, a_getIDsOfNames
, a_invoke
] ++ meths)
getTypeInfoCount :: Ptr () -> Ptr Word32 -> IO HRESULT
getTypeInfoCount iptr pctInfo = do
-- putMessage "getTypeInfoCount"
writeWord32 pctInfo 1
return s_OK
foreign export stdcall dynamic export_getTypeInfoCount
:: (Ptr () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
getTypeInfo :: DispState -> Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
getTypeInfo disp_state this iTInfo lcid ppTInfo
| iTInfo /= 0 = return tYPE_E_ELEMENTNOTFOUND
| ppTInfo == nullPtr = return e_POINTER
| otherwise = do
-- putMessage "getTypeInfo"
poke (castPtr ppTInfo) nullPtr
let ppITInfo_ref = disp_ti disp_state
(hr, pITInfo) <- do
pITInfo <- readIORef ppITInfo_ref
-- load up the typelib is done the first time
-- around. Cannot do it earlier (or lazily), since
-- loading is dependent on the 'lcid'.
--
-- The caching of the ITypeInfo* only works because
-- we keep a disp_state for each interface.
if (pITInfo == nullPtr) then do
ppITInfo <- allocOutPtr
hr <- loadTypeInfo (disp_libid disp_state) (disp_iid disp_state) lcid ppITInfo
-- putMessage ("getTypeInfo: " ++ show hr)
if (failed hr) then
return (hr, undefined)
else do
pITInfo <- peek ppITInfo
writeIORef ppITInfo_ref pITInfo
return (s_OK, pITInfo)
else
return (s_OK, pITInfo)
-- do an AddRef() since we're handing out a copy to it.
-- => when the GetIDsOfNames() and Invoke() implementations
-- below call getTypeInfo, they'll have to call Release()
-- when finished with the result here.
--
if (failed hr) then
return hr
else do
punk <- unmarshallIUnknown True{-addRef and finalise-} pITInfo
-- to counter the effect of running the finaliser on pITInfo.
Com.addRef punk
poke (castPtr ppTInfo) pITInfo
return s_OK
-- Loading the type info is lcid sensitive, so we
-- have to manually invoke this from within GetTypeInfo()
loadTypeInfo :: Either LIBID String
-> IID iid
-> LCID
-> Ptr (PrimIP (ITypeInfo ()))
-> IO HRESULT
loadTypeInfo tlb_loc iid lcid ppITI = do
(hr, pITypeLib) <-
catch
(case tlb_loc of
Left libid -> do
ip <- loadRegTypeLib libid 1 0 (fromIntegral (primLangID lcid))
return (s_OK, ip)
-- load it in silently
Right path -> do
ip <- loadTypeLibEx path False{-don't register-}
return (s_OK, ip))
(\ ex -> do
putMessage "Failed to load typelib"
return (fromMaybe e_FAIL (coGetErrorHR ex), interfaceNULL))
if (failed hr) then
return hr
else do
hr <- pITypeLib # getTypeInfoOfGuid iid ppITI
-- pITypeLib is a finalised i-pointer, and will be
-- released in due course.
-- NOTE: potential bug farm.
return hr
-- from oleauto.h
foreign import ccall "primLoadRegTypeLib"
primLoadRegTypeLib :: Ptr () -> Word16 -> Word16 -> Word32 -> Ptr () -> IO HRESULT
foreign export stdcall dynamic export_getTypeInfo
:: (Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT) -> IO (Ptr ())
getIDsOfNames :: DispState
-> Ptr (IDispatch ())
-> Ptr (IID ())
-> Ptr WideString
-> Word32
-> LCID
-> Ptr DISPID
-> IO HRESULT
getIDsOfNames disp_state this riid rgszNames cNames lcid rgDispID = do
-- putMessage ("getIDs: " ++ show cNames)
pti <- allocOutPtr
hr <- getTypeInfo disp_state this 0 lcid pti
if (failed hr) then do
free pti
return hr
else do
prim_ti <- peek (castPtr pti)
free pti
-- pw <- peek (castPtr rgszNames)
hr <- prim_ti # getIDsOfNamesTI rgszNames cNames rgDispID
return hr
foreign export stdcall dynamic export_getIDsOfNames
:: (Ptr (IDispatch ()) -> Ptr (IID ()) -> Ptr WideString -> Word32 -> LCID -> Ptr DISPID -> IO HRESULT) -> IO (Ptr ())
invoke :: DispState
-> Ptr (IDispatch ())
-> DISPID
-> Ptr (IID a)
-> LCID
-> Word32
-> Ptr DISPPARAMS
-> Ptr VARIANT
-> Ptr EXCEPINFO
-> Ptr Word32
-> IO HRESULT
invoke disp_state this dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr = do
iid <- unmarshallIID False riid
-- putMessage ("invoke: " ++ show (dispIdMember, iid))
if (iid /= castIID iidNULL) then
return dISP_E_UNKNOWNINTERFACE
else do
pti <- allocOutPtr
hr <- getTypeInfo disp_state this 0 lcid pti
if (failed hr) then do
free pti
return hr
else do
prim_ti <- peek (castPtr pti)
let ip = disp_ip disp_state
-- hand over to the typelib marshaller, but making sure that
-- any exceptions within the user code will be handled correctly.
clearException
hr <- prim_ti # invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
fillException pExcepInfo lcid
ip <- unmarshallIUnknown False prim_ti
ip # Com.release
return hr
invokeTI :: IUnknown a
-> DISPID
-> Word32
-> Ptr DISPPARAMS
-> Ptr VARIANT
-> Ptr EXCEPINFO
-> Ptr Word32
-> Ptr (ITypeInfo a)
-> IO HRESULT
invokeTI ip dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr this = do
iptr_fo <- marshallIUnknown ip
let offset = (11::Int)
lpVtbl <- peek (castPtr this)
methPtr <- indexPtr lpVtbl offset
withForeignPtr iptr_fo $ \ iptr ->
prim_invokeTI methPtr (castPtr this) iptr dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
foreign import stdcall dynamic
prim_invokeTI :: Ptr (ITypeInfo a) -> Ptr () -> Ptr () -> DISPID -> Word32
-> Ptr DISPPARAMS -> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT
getTypeInfoOfGuid :: IID iid -> Ptr (PrimIP (ITypeInfo ())) -> IUnknown a -> IO HRESULT
getTypeInfoOfGuid iid ppITI this = do
let offset = (6::Int)
pthis <- marshallIUnknown this
let a = foreignPtrToPtr pthis
lpVtbl <- peek (castPtr a)
methPtr <- indexPtr lpVtbl offset
piid <- marshallIID iid
withForeignPtr pthis $ \ pthis ->
withForeignPtr piid $ \ piid ->
prim_getTypeInfoOfGuid methPtr pthis piid ppITI
foreign import stdcall dynamic
prim_getTypeInfoOfGuid :: Ptr () -> Ptr (Ptr a)
-> Ptr (IID iid) -> Ptr (PrimIP (ITypeInfo ())) -> IO HRESULT
getIDsOfNamesTI :: Ptr WideString -> Word32 -> Ptr DISPID -> Ptr (ITypeInfo ()) -> IO HRESULT
getIDsOfNamesTI rgszNames cNames rgDispID this = do
let offset = (10::Int)
lpVtbl <- peek (castPtr this)
methPtr <- indexPtr lpVtbl offset
prim_getIDsOfNamesTI methPtr (castPtr this) rgszNames cNames rgDispID
foreign import stdcall dynamic
prim_getIDsOfNamesTI :: Ptr (ITypeInfo ()) -> Ptr () -> Ptr WideString -> Word32 -> Ptr DISPID -> IO HRESULT
clearException :: IO ()
clearException = return ()
fillException :: Ptr EXCEPINFO
-> LCID
-> IO ()
fillException _ _ = return ()
foreign export stdcall dynamic export_invoke
:: (Ptr (IDispatch ()) -> DISPID -> Ptr (IID a) -> LCID -> Word32 -> Ptr DISPPARAMS
-> Ptr VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
data TypeInfo a = TypeInfo__
type ITypeInfo a = IUnknown (TypeInfo a)
--makeLangID :: Word16 -> Word16 -> Word16
--makeLangID p s = (shiftL p 10) .|. s
primLangID :: Word32 -> Word32
primLangID w = (w .&. 0x3ff)
\end{code}
Manufacturing method tables out of a list of method pointers.
\begin{code}
createVTable :: [Ptr ()] -> IO (VTable iid objState)
createVTable methods = do
vtbl <- alloc (sizeofPtr * fromIntegral no_meths)
sequence (zipWith (pokeElemOff vtbl) [(0::Int)..] methods)
return (vtbl, no_meths)
where
no_meths = length methods
unmarshallVTable :: VTable iid objState -> IO [Ptr ()]
unmarshallVTable (vtbl, no_meths) =
mapM (peekElemOff vtbl) [(0::Int)..no_meths]
createComVTable :: [Ptr ()] -> IO (ComVTable iid objState)
createComVTable methods = do
m_queryInterface <- export_queryInterface queryInterface
m_addRef <- export_addRef addRef
m_release <- export_release release
createVTable (m_queryInterface: m_addRef: m_release: methods)
\end{code}