%
% (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)
	, createDualVTable  -- :: Either LIBID String -> IID (IUnknown iid) -> [Ptr ()] -> IO (ComVTable (IDispatch ()) 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
	, mkBaseIface
	
	, export_getTypeInfoCount
	, export_getTypeInfo
	, export_getIDsOfNames
	, export_invoke

	, dllLockServer
	, dllUnlockServer
	, dllGetLockCount

#ifdef DEBUG_REFCOUNT
	, dumpLiveObjects
#endif
	) where

import HDirect
import Data.Word
import Data.Int
import Data.IORef       ( IORef, readIORef, writeIORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import System.IO        ( fixIO )
import Com     hiding ( queryInterface, addRef, release )
import qualified Com ( queryInterface, addRef, release )
import Automation ( IDispatch, VARIANT, iidIDispatch, DISPID )
import Foreign.StablePtr
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Data.Maybe   ( fromMaybe )
import Data.Bits ( (.&.) )
import ComException
import WideString
import Monad
import List

#ifdef DEBUG_REFCOUNT
import Debug.Trace
#endif
\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
	      }
  | BaseIface { ifaceGUID    :: GUID
	      , ifaceInhGUID :: GUID
	      }

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)

mkBaseIface :: IID iid1 -> IID iid2 -> ComInterface objState
mkBaseIface iid inhIID = BaseIface (iidToGUID iid) (iidToGUID inhIID)

\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
  (_,_,ip)  <- lookupInterface initial_iid (iu_ifaces iu)
  dllLockServer
  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
      poke 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
#ifdef DEBUG_REFCOUNT
     , iu_id       :: Int
     , iu_dll      :: String
#endif
     }

type IUnkIfaceInfo = [(GUID, Bool, IUnknown ())]

#ifdef DEBUG_REFCOUNT
{-# NOINLINE objectsList #-}
objectsList :: IORef (Int,[IUnkState])
objectsList = unsafePerformIO (newIORef (0,[]))
#endif

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
#ifdef DEBUG_REFCOUNT
     (nextid,lst) <- readIORef objectsList
     let iptrs = map (mkIf stbl_st iptrs) iface_list
         iu_st = IUnkState iptrs releaseAction ref_cnt nextid dll_path
     writeIORef objectsList (nextid+1,iu_st:lst)
#else
     let iptrs = map (mkIf stbl_st iptrs) iface_list
         iu_st = IUnkState iptrs releaseAction ref_cnt
#endif
     newStablePtr (objState, iu_st)
   )
 where
  mkIf st iptrs (Iface iid vtbl)              = 
     (iid, False, unsafePerformIO (createIPointer st vtbl))
  mkIf st iptrs (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
     )
  mkIf st iptrs (BaseIface iid inhIID) = 
     (iid, False, findInhIPointer inhIID iptrs)
     
  findInhIPointer inhGUID [] = error "Bad interface ID"
  findInhIPointer inhGUID ((guid,_,iptr):iptrs)
    | inhGUID == guid = iptr
    | otherwise       = findInhIPointer inhGUID iptrs
\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
   v <- readRefCount iptr
#ifdef DEBUG_REFCOUNT
   iu <- getIUnkState iptr
   putTraceMsg ("ADDREF: "++iu_dll iu++" (RefCount="++show v++")")
#endif
   writeRefCount iptr $! (v+1)
   return (fromIntegral v)

release :: Ptr (IUnknown a) -> IO Word32
release iptr = do
   v <- readRefCount iptr
#ifdef DEBUG_REFCOUNT
   iu <- getIUnkState iptr
   putTraceMsg ("RELEASE: "++iu_dll iu++" (RefCount="++show v++")")
#endif
   let v' = v-1
   writeRefCount iptr $! v'
   if v' <= 0 then do
#ifdef DEBUG_REFCOUNT
      (nextid,lst) <- readIORef objectsList
      writeIORef objectsList (nextid,filter (\x -> iu_id x /= iu_id iu) lst)
#endif
      releaseObj iptr
      return $! fromIntegral 0
    else
      return $! fromIntegral (v-1)

#ifdef DEBUG_REFCOUNT
dumpLiveObjects :: IO ()
dumpLiveObjects = do
  (nextid,lst) <- readIORef objectsList
  res <- mapM (\x -> readIORef (iu_refcnt x) >>= \cnt -> return (iu_id x,iu_dll x,cnt)) lst
  putTraceMsg ("LIVE OBJECTS: "++show res)
#endif
\end{code}

\begin{code}
foreign import stdcall "wrapper" export_queryInterface :: (Ptr (IUnknown a) -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO Int32) -> IO (Ptr ())
foreign import stdcall "wrapper" export_addRef  :: (Ptr (IUnknown a) -> IO Word32) -> IO (Ptr ())
foreign import stdcall "wrapper" 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..   
   -- shouldn't we free the object? --SDM
   dllUnlockServer
   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 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 ip 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
    st     <- mkDispatchState libid iid
    vtable <- createDispVTable [] ip st
    i <- cloneIPointer ip vtable
    return i

mkDispatchState :: Either LIBID String
		-> IID (IUnknown iid)
		-> IO DispState
mkDispatchState libid iid = do
   pTInfo_ref <- newIORef nullPtr
   return (DispState libid (coerceIID iid) 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_ti    :: (IORef (PrimIP (ITypeInfo ())))
   }

type DISPPARAMS = Ptr () -- abstract, really.
type EXCEPINFO  = Ptr () -- abstract, really.

createDispVTable :: [Ptr ()] 
	         -> IUnknown a
	         -> DispState
		 -> IO (ComVTable (IDispatch ()) DispState)
createDispVTable meths ip 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 ip disp_st)
  createComVTable ([ a_getTypeInfoCount
		   , a_getTypeInfo
		   , a_getIDsOfNames
		   , a_invoke
		   ] ++ meths)
		   
createDualVTable :: Either LIBID String
		 -> IID (IUnknown iid)
		 -> [Ptr ()] 
		 -> IO (ComVTable (IDispatch ()) objState)
createDualVTable libid iid meths = do
  disp_st <- mkDispatchState libid iid
  a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount
  a_getTypeInfo	     <- export_getTypeInfo      (getTypeInfo disp_st)
  a_getIDsOfNames    <- export_getIDsOfNames	(getIDsOfNames disp_st)
  a_invoke	     <- export_invoke		(\this_ptr dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr -> do
                                                    this <- unmarshallIUnknown False this_ptr
                                                    ip <- Com.queryInterface (coerceIID (disp_iid disp_st)) this
                                                    hr <- invoke ip disp_st this_ptr dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr
                                                    Com.release ip
                                                    return hr)
  createComVTable ([ a_getTypeInfoCount
		   , a_getTypeInfo
		   , a_getIDsOfNames
		   , a_invoke
		   ] ++ meths)

getTypeInfoCount :: Ptr () -> Ptr Word32 -> IO HRESULT
getTypeInfoCount iptr pctInfo = do
  writeWord32 pctInfo 1
  return s_OK

foreign import stdcall "wrapper" export_getTypeInfoCount
	    :: (Ptr () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())

getTypeInfo :: DispState -> Ptr (IDispatch a) -> 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
      (hr, pITInfo) <- do
              pITInfo <- readIORef (disp_ti disp_state)
              -- 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
                        if (failed hr)
                          then do
                                free ppITInfo
                                return (hr, undefined)
                          else do                                
                                pITInfo  <- peek ppITInfo
                                free ppITInfo
                                writeIORef (disp_ti disp_state) pITInfo
                                return (s_OK, pITInfo)
                else do
                        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 do
          poke (castPtr ppTInfo) nullPtr
          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 import stdcall "wrapper" 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 import stdcall "wrapper" export_getIDsOfNames
	    :: (Ptr (IDispatch ()) -> Ptr (IID ()) -> Ptr WideString -> Word32 -> LCID -> Ptr DISPID -> IO HRESULT) -> IO (Ptr ())

invoke :: IUnknown a
       -> DispState
       -> Ptr (IDispatch b)
       -> DISPID
       -> Ptr (IID c)
       -> LCID
       -> Word32
       -> Ptr DISPPARAMS
       -> Ptr VARIANT
       -> Ptr EXCEPINFO
       -> Ptr Word32
       -> IO HRESULT
invoke ip disp_state this dispIdMember riid lcid wFlags pDispParams pVarResult pExcepInfo puArgErr = do
   iptr <- marshallIUnknown ip
   iid <- unmarshallIID False riid
   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)
                     free pti
                     -- hand over to the typelib marshaller, but making sure that
                     -- any exceptions within the user code will be handled correctly.
                     clearException
                     let offset    = (11::Int)
                     lpVtbl  <- peek (castPtr prim_ti)
                     methPtr <- indexPtr lpVtbl offset
                     hr <- prim_invokeTI methPtr prim_ti iptr dispIdMember wFlags pDispParams pVarResult pExcepInfo puArgErr
                     fillException pExcepInfo lcid
                     ip <- unmarshallIUnknown False prim_ti
                     ip # Com.release
                     return hr

foreign import stdcall "dynamic"
  prim_invokeTI :: Ptr () -> Ptr (ITypeInfo a) -> Ptr (IUnknown b) -> 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
  lpVtbl  <- peek (castPtr pthis)
  methPtr <- indexPtr lpVtbl offset
  piid	  <- marshallIID iid
  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 import stdcall "wrapper" 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}


\begin{code}
{-# NOINLINE dllLockCount #-}
dllLockCount :: IORef Int
dllLockCount = unsafePerformIO $ newIORef 0

dllLockServer :: IO ()
dllLockServer = do
  count <- readIORef dllLockCount
  writeIORef dllLockCount $! count+1
  
dllUnlockServer :: IO ()
dllUnlockServer = do
  count <- readIORef dllLockCount
  writeIORef dllLockCount $! count-1
  
dllGetLockCount :: IO Int
dllGetLockCount = readIORef dllLockCount
\end{code}