{-# OPTIONS -#include "System/Win32/Com/Server_stub.h" #-}
{-# OPTIONS -#include "comPrim.h" #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Win32.Com.Server
-- Copyright   :  (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  sof@galois.com
-- Stability   :  provisional
-- Portability :  portable
--
-- 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 :-)
-- 
-----------------------------------------------------------------------------
module System.Win32.Com.Server
	(
	  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 System.Win32.Com.HDirect.HDirect
import Data.Word
import Data.Int
import Data.IORef       ( IORef, readIORef, writeIORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import System.IO        ( fixIO )
import System.Win32.Com     hiding ( queryInterface, addRef, release )
import qualified System.Win32.Com as Com ( addRef, release )
import System.Win32.Com.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 System.Win32.Com.Exception
import System.Win32.Com.HDirect.WideString

import Monad
import List

--Basic types - we're essentially untyped here; safety is provided
--by the abstraction levels above us.

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)

{-
=== 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.
-}

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


{-
=== 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.
-}
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

-- | 'findInterface' is used by both the class factory
-- and 'queryInterface' to check whether the component
-- implements a particular interface.
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

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
     )

{-
'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.)
-}
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

--
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 ())

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 ()

--Accessing data accessible via a Haskell i-pointer - this stuff

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

--Dispatch interface support:

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 import stdcall "wrapper" 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 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 :: 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 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)

--Manufacturing method tables out of a list of method pointers.

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)