%
% (c), 1999 - sof
%

IProvideClassInfo{2} implementation in Haskell

\begin{code}
module ClassInfo
         (
	   mkIProvideClassInfo
	 , mkIProvideClassInfo2

	 , IProvideClassInfo(..)
	 , IProvideClassInfo_
	 , iidIProvideClassInfo

	 , IProvideClassInfo2(..)
	 , IProvideClassInfo2_
	 , iidIProvideClassInfo2

	 ) where

import Com
import Data.Word ( Word32 )
import ComException
import TypeLib
import ComServ
import HDirect ( Ptr, writeAddr )
import ComPrim (lOCALE_USER_DEFAULT)
import System.IO.Unsafe

type ThisPtr = Addr
\end{code}


\begin{code}
data IProvideClassInfo_ a = IProvideClassInfo__ 
type IProvideClassInfo  a = IUnknown (IProvideClassInfo_ a)

iidIProvideClassInfo :: IID (IProvideClassInfo ())
iidIProvideClassInfo = mkIID "{B196B283-BAB4-101A-B69C-00AA00341D07}"

data IProvideClassInfo2_ a = IProvideClassInfo2__ 
type IProvideClassInfo2  a = IProvideClassInfo (IProvideClassInfo2_ a)

iidIProvideClassInfo2 :: IID (IProvideClassInfo2 ())
iidIProvideClassInfo2 = mkIID "{A6BC3AC0-DBAA-11CE-9DE3-00AA004BB851}"

mkIProvideClassInfo :: Either LIBID String
		    -> CLSID
		    -> IO (ComVTable (IProvideClassInfo ()) objState)
mkIProvideClassInfo libid clsid = do
  let mb_tlib = unsafePerformIO (hoistInTLB libid)
  addrOf_gci <- export_gci (getClassInfo mb_tlib clsid)
  createComVTable [addrOf_gci]

mkIProvideClassInfo2 :: Either LIBID String
		     -> CLSID
		     -> IID a
		     -> IO (ComVTable (IProvideClassInfo2 ()) objState)
mkIProvideClassInfo2 libid clsid iid = do
  let mb_tlib = unsafePerformIO (hoistInTLB libid)
  addrOf_gci <- export_gci (getClassInfo mb_tlib clsid)
  addrOf_gg  <- export_gg  (getGUID iid)
  createComVTable [addrOf_gci, addrOf_gg]

\end{code}


\begin{code}
hoistInTLB :: Either LIBID String
	   -> IO (Maybe (ITypeLib ()))
hoistInTLB tlb_loc = 
 catch (
   case tlb_loc of
     Left libid -> do
        ip <- loadRegTypeLib libid 1 0 (fromIntegral lOCALE_USER_DEFAULT)
	return (Just ip)
     Right loc -> do
        ip <- loadTypeLibEx loc False{-don't register-}
	return (Just ip))
  (\ _ -> return Nothing)
\end{code}

\begin{code}
getClassInfo :: Maybe (ITypeLib ()) -> CLSID -> ThisPtr -> Ptr (ITypeInfo ()) -> IO HRESULT
getClassInfo mb_tlib clsid this ppTI 
  | ppTI == nullAddr = return e_POINTER
  | otherwise	    = do
     case mb_tlib of
       Nothing -> return e_FAIL
       Just tl -> do
	 catch (do
           ti <- tl # getTypeInfoOfGuid (clsidToGUID clsid)
	   writeiptr ppTI ti
	   return s_OK)
	  (\ _ -> do
	      writeAddr ppTI nullAddr
	      return e_FAIL)

foreign export stdcall dynamic
   export_gci :: (Addr -> Addr -> IO HRESULT) -> IO Addr
\end{code}

\begin{code}
getGUID :: IID a
	-> ThisPtr
	-> Word32
	-> Ptr GUID
	-> IO HRESULT
getGUID iid this kind pGUID
  | pGUID == nullAddr = return e_POINTER
  | kind  /= 1        = return e_INVALIDARG -- 1 == GUIDKIND_DEFAULT_SOUCE_DISP_IID
  | otherwise         = do
     writeGUID pGUID (iidToGUID iid)
     return s_OK

foreign export stdcall dynamic
   export_gg :: (Addr -> Word32 -> Addr -> IO HRESULT) -> IO Addr
\end{code}